SDCO.m

SDCO ;ALB/RMO - Check Out List Manager Driver; 11 FEB 1993 10:00 am

 ;;5.3;Scheduling;**27,132,149,193,1015**;08/13/93;Build 21

 ;

EN(SDOE,SDCOHDL,SDCOXQB) ; -- main entry point for SDCO CHECK OUT list manager

 ; Input  -- SDOE, SDCOHDL and SDCOXQB  [Optional]

 N SDCOACT,SDEVTF,SDAPTYP

 IF $P($G(^SCE(+SDOE,0)),"^",6) G ENQ ;exit if child

 D EN^VALM("SDCO CHECK OUT")

ENQ ;

 Q

 ;

HDR ; -- header code

 K VALMHDR

 N DFN,SDCL,SDOE0,X,VA,SDELIG,SDATA

 S SDOE0=$G(^SCE(+SDOE,0)),SDCL=+$P(SDOE0,"^",4)

 S DFN=+$P(SDOE0,"^",2) D PID^VADPT

 I $G(SDT)'="" S SDATA=$G(^DPT(DFN,"S",SDT,0))

 S SDELIG=$$ELSTAT^SDUTL2(DFN)

 I $$MHCLIN^SDUTL2(SDCL),'($$COLLAT^SDUTL2(SDELIG)!$P($G(SDATA),U,11)) D

 .S SDGAF=$$NEWGAF^SDUTL2(DFN),SDGAFST=$P(SDGAF,"^")

 .I SDGAFST D

 ..S SDGAFDT=$$FMTE^XLFDT($P(SDGAF,"^",3),"5M"),SDGAFS=$P(SDGAF,"^",2),SDGAFP=$P(SDGAF,"^",4)

 ..S VALMHDR(3)="GAF Date: "_SDGAFDT_"     GAF Score: "_SDGAFS_"     New GAF Required"

 S VALMHDR(1)=$E("Patient: "_$P($G(^DPT(DFN,0)),"^"),1,30)_" ("_VA("BID")_")"

 S:SDCL VALMHDR(1)=$$SETSTR^VALM1($E("Clinic: "_$P($G(^SC(SDCL,0)),"^"),1,20),VALMHDR(1),60,80)

 S VALMHDR(2)=$$SETSTR^VALM1($E($$ORG^SDCOU(+$P(SDOE0,"^",8)),1,20)_" Date/Time: "_$$LOWER^VALM1($$FTIME^VALM1(+SDOE0)),"",1,51)

 S VALMHDR(2)=$$SETSTR^VALM1("Checked Out: "_$S($$COMDT^SDCOU(SDOE):"YES",1:"NO"),VALMHDR(2),60,80)

 Q

 ;

INIT ; -- init variables and list array -- SDOE required

 D BLD

 Q

 ;

BLD ; -- build check out screen

 D CLEAN^VALM10

 K ^TMP("SDCOIDX")

 D HDR

 D EN^SDCO0("SDCO",SDOE,1,.VALMCNT)

 Q

 ;

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 D CLEAN^VALM10,CLEAR^VALM1

 K ^TMP("SDCOIDX"),SDCOXQB

 Q

 ;

EXPND ; -- expand code

 Q

 ;

SDCO      ;ALB/RMO - Check Out List Manager Driver; 11 FEB 1993 10:00 am

 +1       ;;5.3;Scheduling;**27,132,149,193,1015**;08/13/93;Build 21

 +2       ;

EN(SDOE,SDCOHDL,SDCOXQB) ; -- main entry point for SDCO CHECK OUT list manager

 +1       ; Input  -- SDOE, SDCOHDL and SDCOXQB  [Optional]

 +2        NEW SDCOACT,SDEVTF,SDAPTYP

 +3       ;exit if child

           IF $PIECE($GET(^SCE(+SDOE,0)),"^",6)

               GOTO ENQ

 +4        DO EN^VALM("SDCO CHECK OUT")

ENQ       ;

 +1        QUIT 

 +2       ;

HDR       ; -- header code

 +1        KILL VALMHDR

 +2        NEW DFN,SDCL,SDOE0,X,VA,SDELIG,SDATA

 +3        SET SDOE0=$GET(^SCE(+SDOE,0))

           SET SDCL=+$PIECE(SDOE0,"^",4)

 +4        SET DFN=+$PIECE(SDOE0,"^",2)

           DO PID^VADPT

 +5        IF $GET(SDT)'=""

               SET SDATA=$GET(^DPT(DFN,"S",SDT,0))

 +6        SET SDELIG=$$ELSTAT^SDUTL2(DFN)

 +7        IF $$MHCLIN^SDUTL2(SDCL)

               IF '($$COLLAT^SDUTL2(SDELIG)!$PIECE($GET(SDATA),U,11))

                   Begin DoDot:1

 +8                    SET SDGAF=$$NEWGAF^SDUTL2(DFN)

                       SET SDGAFST=$PIECE(SDGAF,"^")

 +9                    IF SDGAFST

                           Begin DoDot:2

 +10                           SET SDGAFDT=$$FMTE^XLFDT($PIECE(SDGAF,"^",3),"5M")

                               SET SDGAFS=$PIECE(SDGAF,"^",2)

                               SET SDGAFP=$PIECE(SDGAF,"^",4)

 +11                           SET VALMHDR(3)="GAF Date: "_SDGAFDT_"     GAF Score: "_SDGAFS_"     New GAF Required"

                           End DoDot:2

                   End DoDot:1

 +12       SET VALMHDR(1)=$EXTRACT("Patient: "_$PIECE($GET(^DPT(DFN,0)),"^"),1,30)_" ("_VA("BID")_")"

 +13       IF SDCL

               SET VALMHDR(1)=$$SETSTR^VALM1($EXTRACT("Clinic: "_$PIECE($GET(^SC(SDCL,0)),"^"),1,20),VALMHDR(1),60,80)

 +14       SET VALMHDR(2)=$$SETSTR^VALM1($EXTRACT($$ORG^SDCOU(+$PIECE(SDOE0,"^",8)),1,20)_" Date/Time: "_$$LOWER^VALM1($$FTIME^VALM1(+SDOE0)),"",1,51)

 +15       SET VALMHDR(2)=$$SETSTR^VALM1("Checked Out: "_$SELECT($$COMDT^SDCOU(SDOE):"YES",1:"NO"),VALMHDR(2),60,80)

 +16       QUIT 

 +17      ;

INIT      ; -- init variables and list array -- SDOE required

 +1        DO BLD

 +2        QUIT 

 +3       ;

BLD       ; -- build check out screen

 +1        DO CLEAN^VALM10

 +2        KILL ^TMP("SDCOIDX")

 +3        DO HDR

 +4        DO EN^SDCO0("SDCO",SDOE,1,.VALMCNT)

 +5        QUIT 

 +6       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        DO CLEAN^VALM10

           DO CLEAR^VALM1

 +2        KILL ^TMP("SDCOIDX"),SDCOXQB

 +3        QUIT 

 +4       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;