MCARP1.m

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

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

 +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

 +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       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