source: FOIAVistA/trunk/r/MEDICINE-MC/MCARP1.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1MCARP1 ;WISC/TJK-PRINT ROUTINES TWO ;5/3/96 08:18
2 ;;2.3;Medicine;**14,15,16**;09/13/1996
3EXIT ;
4 I IOST'?1"P-".E,'$D(MCOUT),$G(Y)'<0 R !!,"* END * Press return to continue: ",X:DTIME
5 K ^UTILITY($J),IO("Q"),MCARGDA,MCARGDT,SSN,MCOUT,VA,DICMX,V
6 K MCARGNM,MCARGRTN,X,DFN,SSN,MCARGNUM,MCARGNAM,MCARZ,DN,D0,FLDS,MCARCODE
7 K DIOEND,DIOBEG,DI,DIC,DJ,BY,A,DICSS,MCARGDT2,MCARPPS
8 K DIEDT,DIQ,DIWF,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DIC,DU,DQI,DY,S,DC
9 K DL,DV,DE,DA,DK,Y,R,RH,C,D,I,J,Q,M,P,N,D1,DIW,DIWL,DIWR,DIWT,PG,Z,L,%T,D2
10 K MCAR,MCARDOB,MCARDTM,MCARHDR,MCARRB,MCARWARD,MCRHR,VADM,VAIN
11 K MCARP,MCFILE,MCESON,MCESKEY,MCROUT,MCTYPE,MCARPS,MCSUP
12 K MCEBRIEF,MCEFULL,MCPBRIEF,MCPFULL,MCPRTRTN,MCBS,MCSTAT
13 K MCARCODE,MCARDE,MCARGNAM,MCARGNUM,MCARGRTN,MCARP,MCARZ,MCBS
14 K MCESS,MCESSEC,MCOUNT,MCPATFLD,MCPRO,MCSUP
15 K ZTQUEUED,ZTREQ,FULL,MCPROP
16 D ^%ZISC
17 Q
18INIT(MCARZ,MCARGDT,MCFILE) ;
19 S PG=0
20 I '$D(MCARGDT2) S X=MCARGDT D DTIME^MCARP S MCARGDT2=X
21 D NOW^%DTC S X=% D DTIME^MCARP S MCARDTM=X
22 ; ------------------------
23 ; SSN = Enternal Format of the patients SSN with the first letter
24 ; of the last name tacked on the end
25 ; ------------------------
26 D DEM^VADPT S MCARGNM=VADM(1),SSN=VA("PID"),X=$P(VADM(3),"^",2),MCARDOB=$S(X'="":X,1:"")
27 I MCFILE=699,($G(MCARGNUM)'="") S MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
28 D KVAR^VADPT
29 D INP^VADPT S MCARWARD=$S(VAIN(4)'="":$P(VAIN(4),U,2),1:"NOT INPATIENT"),MCARRB=VAIN(5) D KVAR^VADPT
30 S MCARHDR=" CONFIDENTIAL "_MCARZ,MCAR="",$P(MCAR,"*",(77-$L(MCARHDR))\2)="*",MCARHDR=MCAR_" "_MCARHDR_" "_MCAR
31 Q
32MCPPROC ; Get require variables
33 N OTEMP,TEMP,OPTION
34 ;MCabPROC <=== name of an option, screen or line edit.
35 ; a = (B => Brief), (F => Full)
36 ; b = (S => Screen Edit), (L => Line Edit), (P => Printing)
37 ; PROC = the name of the procedure
38 S OTEMP=$S(XQY0["SUMMARY":"FP"_$G(MCPRO),1:$P(XQY0,U))
39 S:$L($G(MCPRO))<2 MCPRO=$$MCPROP^MCARP(OTEMP)
40 S MCARP="",(MCARP,MCARGNUM,MCARGNAM)=+$O(^MCAR(697.2,"B",MCPRO,MCARP)),OPTION=$E(OTEMP,3,4)
41 S TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0,MCSUP=+$P(TEMP,U,16)
42 S (MCROUT,MCARDE)=$P(TEMP,U,8),MCFILE=+$P($P(TEMP,U,2),"MCAR(",2),MCESON=+$P(TEMP,U,14),MCESSEC=0,MCESKEY=$P(TEMP,U,15)
43 S MCARGNAM=$P(TEMP,U),MCPATFLD=$P(TEMP,U,12),MCOUNT=0
44 I MCESON,MCESKEY'="" S:$D(^XUSEC(MCESKEY,DUZ)) MCESSEC=1
45 I MCFILE=699 S MCARCODE=$S($P(XQY0,U)["GI":"G",$P(XQY0,U)["NONENDO":"Z",1:"P"),DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,+$P(^MCAR(699,+Y,0),U,12)))"
46 S MCPRTRTN=$P(TEMP,U,5)_"^"_$P(TEMP,U,6)
47 S MCBS=$S(OPTION["B":1,1:0) Q
48 Q
49DELETE ;DELETES GI PROCEDURES Taken from MCARGE routine for size
50 S DIC="^MCAR(699,",DIC(0)="AEQM",DIC("A")="Select Patient Name or Date of Procedure to Delete: ",DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,$P(^MCAR(699,+Y,0),U,12)))"
51 I MCESON S DIC("S")=DIC("S")_",$$SCRDEL^MCESSCR(699)"
52 D ^DIC G EXIT:Y<0 S MCARGDA=+Y
53 S DIR("A")="ARE YOU SURE YOU WANT TO DELETE",DIR("B")="N",DIR(0)="Y"
54 D ^DIR
55 I Y S DA=MCARGDA,DIK="^MCAR(699," D ^DIK W !!,"Procedure Deleted ",MCARGDA=0
56 Q
Note: See TracBrowser for help on using the repository browser.