MCARP1 ;WISC/TJK-PRINT ROUTINES TWO ;5/3/96 08:18
;;2.3;Medicine;**14,15,16**;09/13/1996
EXIT ;
I IOST'?1"P-".E,'$D(MCOUT),$G(Y)'<0 R !!,"* END * Press return to continue: ",X:DTIME
K ^UTILITY($J),IO("Q"),MCARGDA,MCARGDT,SSN,MCOUT,VA,DICMX,V
K MCARGNM,MCARGRTN,X,DFN,SSN,MCARGNUM,MCARGNAM,MCARZ,DN,D0,FLDS,MCARCODE
K DIOEND,DIOBEG,DI,DIC,DJ,BY,A,DICSS,MCARGDT2,MCARPPS
K DIEDT,DIQ,DIWF,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DIC,DU,DQI,DY,S,DC
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
K MCAR,MCARDOB,MCARDTM,MCARHDR,MCARRB,MCARWARD,MCRHR,VADM,VAIN
K MCARP,MCFILE,MCESON,MCESKEY,MCROUT,MCTYPE,MCARPS,MCSUP
K MCEBRIEF,MCEFULL,MCPBRIEF,MCPFULL,MCPRTRTN,MCBS,MCSTAT
K MCARCODE,MCARDE,MCARGNAM,MCARGNUM,MCARGRTN,MCARP,MCARZ,MCBS
K MCESS,MCESSEC,MCOUNT,MCPATFLD,MCPRO,MCSUP
K ZTQUEUED,ZTREQ,FULL,MCPROP
D ^%ZISC
Q
INIT(MCARZ,MCARGDT,MCFILE) ;
S PG=0
I '$D(MCARGDT2) S X=MCARGDT D DTIME^MCARP S MCARGDT2=X
D NOW^%DTC S X=% D DTIME^MCARP S MCARDTM=X
; ------------------------
; SSN = Enternal Format of the patients SSN with the first letter
; of the last name tacked on the end
; ------------------------
D DEM^VADPT S MCARGNM=VADM(1),SSN=VA("PID"),X=$P(VADM(3),"^",2),MCARDOB=$S(X'="":X,1:"")
I MCFILE=699,($G(MCARGNUM)'="") S MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
D KVAR^VADPT
D INP^VADPT S MCARWARD=$S(VAIN(4)'="":$P(VAIN(4),U,2),1:"NOT INPATIENT"),MCARRB=VAIN(5) D KVAR^VADPT
S MCARHDR=" CONFIDENTIAL "_MCARZ,MCAR="",$P(MCAR,"*",(77-$L(MCARHDR))\2)="*",MCARHDR=MCAR_" "_MCARHDR_" "_MCAR
Q
MCPPROC ; Get require variables
N OTEMP,TEMP,OPTION
;MCabPROC <=== name of an option, screen or line edit.
; a = (B => Brief), (F => Full)
; b = (S => Screen Edit), (L => Line Edit), (P => Printing)
; PROC = the name of the procedure
S OTEMP=$S(XQY0["SUMMARY":"FP"_$G(MCPRO),1:$P(XQY0,U))
S:$L($G(MCPRO))<2 MCPRO=$$MCPROP^MCARP(OTEMP)
S MCARP="",(MCARP,MCARGNUM,MCARGNAM)=+$O(^MCAR(697.2,"B",MCPRO,MCARP)),OPTION=$E(OTEMP,3,4)
S TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0,MCSUP=+$P(TEMP,U,16)
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)
S MCARGNAM=$P(TEMP,U),MCPATFLD=$P(TEMP,U,12),MCOUNT=0
I MCESON,MCESKEY'="" S:$D(^XUSEC(MCESKEY,DUZ)) MCESSEC=1
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)))"
S MCPRTRTN=$P(TEMP,U,5)_"^"_$P(TEMP,U,6)
S MCBS=$S(OPTION["B":1,1:0) Q
Q
DELETE ;DELETES GI PROCEDURES Taken from MCARGE routine for size
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)))"
I MCESON S DIC("S")=DIC("S")_",$$SCRDEL^MCESSCR(699)"
D ^DIC G EXIT:Y<0 S MCARGDA=+Y
S DIR("A")="ARE YOU SURE YOU WANT TO DELETE",DIR("B")="N",DIR(0)="Y"
D ^DIR
I Y S DA=MCARGDA,DIK="^MCAR(699," D ^DIK W !!,"Procedure Deleted ",MCARGDA=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARP1 3046 printed Apr 09, 2024@21:16:40 Page 2
MCARP1 ;WISC/TJK-PRINT ROUTINES TWO ;5/3/96 08:18
+1 ;;2.3;Medicine;**14,15,16**;09/13/1996
EXIT ;
+1 IF IOST'?1"P-".E
IF '$DATA(MCOUT)
IF $GET(Y)'<0
READ !!,"* END * Press return to continue: ",X:DTIME
+2 KILL ^UTILITY($JOB),IO("Q"),MCARGDA,MCARGDT,SSN,MCOUT,VA,DICMX,V
+3 KILL MCARGNM,MCARGRTN,X,DFN,SSN,MCARGNUM,MCARGNAM,MCARZ,DN,D0,FLDS,MCARCODE
+4 KILL DIOEND,DIOBEG,DI,DIC,DJ,BY,A,DICSS,MCARGDT2,MCARPPS
+5 KILL DIEDT,DIQ,DIWF,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DIC,DU,DQI,DY,S,DC
+6 KILL 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
+7 KILL MCAR,MCARDOB,MCARDTM,MCARHDR,MCARRB,MCARWARD,MCRHR,VADM,VAIN
+8 KILL MCARP,MCFILE,MCESON,MCESKEY,MCROUT,MCTYPE,MCARPS,MCSUP
+9 KILL MCEBRIEF,MCEFULL,MCPBRIEF,MCPFULL,MCPRTRTN,MCBS,MCSTAT
+10 KILL MCARCODE,MCARDE,MCARGNAM,MCARGNUM,MCARGRTN,MCARP,MCARZ,MCBS
+11 KILL MCESS,MCESSEC,MCOUNT,MCPATFLD,MCPRO,MCSUP
+12 Press return to continue: KILL ZTQUEUED,ZTREQ,FULL,MCPROP
+13 DO ^%ZISC
+14 QUIT
INIT(MCARZ,MCARGDT,MCFILE) ;
+1 SET PG=0
+2 IF '$DATA(MCARGDT2)
SET X=MCARGDT
DO DTIME^MCARP
SET MCARGDT2=X
+3 DO NOW^%DTC
SET X=%
DO DTIME^MCARP
SET MCARDTM=X
+4 ; ------------------------
+5 ; SSN = Enternal Format of the patients SSN with the first letter
+6 ; of the last name tacked on the end
+7 ; ------------------------
+8 DO DEM^VADPT
SET MCARGNM=VADM(1)
SET SSN=VA("PID")
SET X=$PIECE(VADM(3),"^",2)
SET MCARDOB=$SELECT(X'="":X,1:"")
+9 IF MCFILE=699
IF ($GET(MCARGNUM)'="")
SET MCARGNAM=$PIECE(^MCAR(697.2,MCARGNUM,0),U)
+10 DO KVAR^VADPT
+11 DO INP^VADPT
SET MCARWARD=$SELECT(VAIN(4)'="":$PIECE(VAIN(4),U,2),1:"NOT INPATIENT")
SET MCARRB=VAIN(5)
DO KVAR^VADPT
+12 SET MCARHDR=" CONFIDENTIAL "_MCARZ
SET MCAR=""
SET $PIECE(MCAR,"*",(77-$LENGTH(MCARHDR))\2)="*"
SET MCARHDR=MCAR_" "_MCARHDR_" "_MCAR
+13 QUIT
MCPPROC ; Get require variables
+1 NEW OTEMP,TEMP,OPTION
+2 ;MCabPROC <=== name of an option, screen or line edit.
+3 ; a = (B => Brief), (F => Full)
+4 ; b = (S => Screen Edit), (L => Line Edit), (P => Printing)
+5 ; PROC = the name of the procedure
+6 SET OTEMP=$SELECT(XQY0["SUMMARY":"FP"_$GET(MCPRO),1:$PIECE(XQY0,U))
+7 if $LENGTH($GET(MCPRO))<2
SET MCPRO=$$MCPROP^MCARP(OTEMP)
+8 SET MCARP=""
SET (MCARP,MCARGNUM,MCARGNAM)=+$ORDER(^MCAR(697.2,"B",MCPRO,MCARP))
SET OPTION=$EXTRACT(OTEMP,3,4)
+9 SET TEMP=$GET(^MCAR(697.2,MCARP,0))
SET MCESS=0
SET MCSUP=+$PIECE(TEMP,U,16)
+10 SET (MCROUT,MCARDE)=$PIECE(TEMP,U,8)
SET MCFILE=+$PIECE($PIECE(TEMP,U,2),"MCAR(",2)
SET MCESON=+$PIECE(TEMP,U,14)
SET MCESSEC=0
SET MCESKEY=$PIECE(TEMP,U,15)
+11 SET MCARGNAM=$PIECE(TEMP,U)
SET MCPATFLD=$PIECE(TEMP,U,12)
SET MCOUNT=0
+12 IF MCESON
IF MCESKEY'=""
if $DATA(^XUSEC(MCESKEY,DUZ))
SET MCESSEC=1
+13 IF MCFILE=699
SET MCARCODE=$SELECT($PIECE(XQY0,U)["GI":"G",$PIECE(XQY0,U)["NONENDO":"Z",1:"P")
SET DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,+$P(^MCAR(699,+Y,0),U,12)))"
+14 SET MCPRTRTN=$PIECE(TEMP,U,5)_"^"_$PIECE(TEMP,U,6)
+15 SET MCBS=$SELECT(OPTION["B":1,1:0)
QUIT
+16 QUIT
DELETE ;DELETES GI PROCEDURES Taken from MCARGE routine for size
+1 SET DIC="^MCAR(699,"
SET DIC(0)="AEQM"
SET DIC("A")="Select Patient Name or Date of Procedure to Delete: "
SET DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,$P(^MCAR(699,+Y,0),U,12)))"
+2 IF MCESON
SET DIC("S")=DIC("S")_",$$SCRDEL^MCESSCR(699)"
+3 DO ^DIC
if Y<0
GOTO EXIT
SET MCARGDA=+Y
+4 SET DIR("A")="ARE YOU SURE YOU WANT TO DELETE"
SET DIR("B")="N"
SET DIR(0)="Y"
+5 DO ^DIR
+6 IF Y
SET DA=MCARGDA
SET DIK="^MCAR(699,"
DO ^DIK
WRITE !!,"Procedure Deleted ",MCARGDA=0
+7 QUIT
