ASDCR.m

ASDCR ; IHS/ADC/PDW/ENM - CHART REQUEST (FUTURE) ; [ 03/25/1999  11:48 AM ]

 ;;5.0;IHS SCHEDULING;;MAR 25, 1999

 ; -- uses non-namespaced variables for calls to VA rtns

 ;

 D DT^DICRW

A1 ;

 K SDMADE S ASDCR=""

 S DIC=44,DIC(0)="AEMQ" W !!

 S DIC("A")="REQUEST CHARTS FOR REVIEW FOR WHICH CLINIC: "

 S DIC("S")="I $P(^(0),U,3)=""C"",$D(^(""SL""))"

 D ^DIC K DIC G END:X[U!(Y<0)

 S SC=+Y,YY=Y,SDSL=$S($D(^SC(SC,"SL")):+^("SL"),1:"") K SDRE,SDIN,SDRE1

 ;

 I $D(^SC(SC,"I")) D

 . S SDIN=+^SC(SC,"I"),SDRE=+$P(^("I"),U,2),Y=SDRE D DTS^SDUTL S SDRE1=Y

 ;

 I $S('$D(SDIN):0,'SDIN:0,SDIN>DT:0,SDRE'>DT&(SDRE):0,1:1) D  G A1

 . W !,*7,"Clinic is inactive ",$S(SDRE:"from ",1:"as of ")

 . S Y=SDIN D DTS^SDUTL W Y,$S(SDRE:" to "_SDRE1,1:"")

 ;

 ;

OTHER S DIR(0)="F^2:200"

 S DIR("A")="DELIVER CHARTS TO (PROVIDER/LOCATION/EXT.)"

 S DIR("?")=" "

 S DIR("?",1)="Enter the clinic/provider who is requesting the charts"

 S DIR("?",2)="with physical location and extension (Westley/2W5/x1669)"

 D ^DIR K DIR G A1:$D(DIRUT) S SDZPL=Y

 ;

TIME ; -- ask user for date/time to be ready

 K DIR S DIR(0)="DA^"_$$DAYS_"::EFT",DIR("B")=$$DAYSP,DIR("?")=" "

 S DIR("?",1)="Enter the date@time you would like the charts to be ready."

 S DIR("?",2)="Please allow at least "_$$DAYSN_" days for charts to be pulled."

 S DIR("A")="DATE/TIME NEEDED:  " D ^DIR K DIR G A1:$D(DIRUT),A1:Y<1

 ;

 S SDZY=$S(Y[".":Y,1:Y_".08"),SDZYY=$P(SDZY,".")

 ;

PT ; -- get patient

 W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC K DIC,I,J S DFN=+Y

 I Y<0 G PRT:$D(SDMADE),A1:'$D(SDMADE)

 ;

 I $S('$D(^DPT(DFN,.35)):0,$P(^(.35),U,1)]"":1,1:0) D

 . W *7,!,"** PATIENT HAS DIED! **"

 ;

 F SDPR=DT:0 S SDPR=$O(^DPT(+Y,"S",SDPR)) Q:SDPR=""!(SDPR>(DT+.2400))  D

 . I $P(^DPT(+Y,"S",SDPR,0),U,2)'["C",$P(^(0),U,2)'["N" S I(SDPR)=+^(0)

 ;

 S J=0 F  S J=$O(^DPT(DFN,"DE",J)) Q:'$D(^(+J,0))  S:$P(^(0),U,2)'["I" J(+^(0))=""

 F SDPR=0:0 S SDPR=$O(I(SDPR)) Q:SDPR=""  D

 . F I=0:0 S I=$O(^SC(I(SDPR),"S",SDPR,1,I)) Q:'$D(^(+I,0))  D

 .. I ^SC(I(SDPR),"S",SDPR,1,I,0)-DFN=0 D

 ... D GOT S D=$P(^DPT(DFN,0),U,2)="F"

 ;

 I ('$D(J(SC)))&('$D(J(+$P(^SC(SC,"SL"),U,5)))) D ENR

 ;

 S Y=SDZY D OKTD^SDI G PT

 ;

 ;

ENR ; -- enroll patient in clinic

 S Y=$P(^SC(SC,"SL"),U,5) I '$D(^SC(+Y,0)) S Y=+SC

 S Y=$P(^SC(Y,0),U,1)

 S SDY=Y,X="NOW",%DT="XT" D ^%DT S HEY=Y

 S DA=DFN,DR="3///"_SDY,(DIE,DIC)="^DPT(",DP=2

 S DR(2,2.001)=".01///"_SDY_";1///"_HEY

 S DR(3,2.011)=".01///"_HEY_";1///O" D ^DIE K DR

 Q

 ;

GOT ;W !,"REQUESTED FOR "_$E(SDPR_"000",9,12)_" ON "

 S SDMADE="" S:'$D(^SC(I(SDPR),"S",0)) ^(0)="^44.001DA^^" Q

 ;

PRT ; -- prints out routing slips for patients selected

 I $$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.14)="NO" G END

 K ASDCR,SDZPL

 S SDX="ADD",SDSP="N"

 S (SDIQ,DIV,SDHS,SDPP,APCHSTYP,SDAIU,SDREP)="",SDNFF=0

 W !!,"TO BYPASS PRINTING OF ROUTING SLIPS NOW - TYPE IN ^"

 D DIV^SDUTL I $T D ROUT^SDDIV G:Y<0 END

 S VAUTC=0,VAUTC($P(^SC(SC,0),U))=SC,ORDER=2,SDSTART=""

 S SDATE=SDZYY

 S APDATE=$E(SDATE,4,5)_"/"_$E(SDATE,6,7)_"/"_$E(SDATE,2,3)

 S PRDATE=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)

 S %ZIS="Q",%ZIS("B")=$$CRPTR D ^%ZIS

 G END:POP,QUE:$D(IO("Q")) D START^SDROUT,END Q

 ;

QUE ;

 K IO("Q"),ZTSAVE

 F %="DIV","SDREP","SDSP","SDX","SDZPL","DUZ(2)","DT","SDSTART","SDATE","APDATE","PRDATE","SDIQ","YY","SDHS","SDPP","APCHSTYP","SDNFF","SDAIU","VAUTC(","VAUTC","ORDER" S ZTSAVE(%)=""

 S ZTRTN="START^SDROUT",ZTDESC="ROUTING SLIPS"

 D ^%ZTLOAD K ZTSK D HOME^%ZIS G END

 ;

END K %,%DT,APCHSTYP,D,DA,DFN,DIC,DIE,DP,DR,GDATE,I,SDZY,J,PRDATE,SDATE

 K SDHS,SDAIU,SDNFF,SDPP,SC,SD,SDAPTYP,SDD,SDINP,SDIQ,SDPL,SDPR,SDRT

 K SDSC,SDSL,SDTTM,SDY,SDX,SDZPL,X,Y,Y1,SDMADE,ASDCR,YY,SDZYY

 D END^SDROUT1

 Q

 ;

DAYS() ; -- returns default first date for charts to be ready

 NEW X1,X2,X

 S X1=DT,X2=$$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.07)

 S:X2="" X2=3 D C^%DTC

 Q X_".0800"

 ;

DAYSP() ; -- return default day in readable format

 Q $$FMTE^XLFDT($$DAYS,2)

 ;

 ;

DAYSN() ; -- returns default # of days

 Q $$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.07)

 ;

CRPTR() ; -- returns default chart request printer

 Q $$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.05)

ASDCR     ; IHS/ADC/PDW/ENM - CHART REQUEST (FUTURE) ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;IHS SCHEDULING;;MAR 25, 1999

 +2       ; -- uses non-namespaced variables for calls to VA rtns

 +3       ;

 +4        DO DT^DICRW

A1        ;

 +1        KILL SDMADE

           SET ASDCR=""

 +2        SET DIC=44

           SET DIC(0)="AEMQ"

           WRITE !!

 +3        SET DIC("A")="REQUEST CHARTS FOR REVIEW FOR WHICH CLINIC: "

 +4        SET DIC("S")="I $P(^(0),U,3)=""C"",$D(^(""SL""))"

 +5        DO ^DIC

           KILL DIC

           IF X[U!(Y<0)

               GOTO END

 +6        SET SC=+Y

           SET YY=Y

           SET SDSL=$SELECT($DATA(^SC(SC,"SL")):+^("SL"),1:"")

           KILL SDRE,SDIN,SDRE1

 +7       ;

 +8        IF $DATA(^SC(SC,"I"))

               Begin DoDot:1

 +9                SET SDIN=+^SC(SC,"I")

                   SET SDRE=+$PIECE(^("I"),U,2)

                   SET Y=SDRE

                   DO DTS^SDUTL

                   SET SDRE1=Y

               End DoDot:1

 +10      ;

 +11       IF $SELECT('$DATA(SDIN):0,'SDIN:0,SDIN>DT:0,SDRE'>DT&(SDRE):0,1:1)

               Begin DoDot:1

 +12               WRITE !,*7,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of ")

 +13               SET Y=SDIN

                   DO DTS^SDUTL

                   WRITE Y,$SELECT(SDRE:" to "_SDRE1,1:"")

               End DoDot:1

               GOTO A1

 +14      ;

 +15      ;

OTHER      SET DIR(0)="F^2:200"

 +1        SET DIR("A")="DELIVER CHARTS TO (PROVIDER/LOCATION/EXT.)"

 +2        SET DIR("?")=" "

 +3        SET DIR("?",1)="Enter the clinic/provider who is requesting the charts"

 +4        SET DIR("?",2)="with physical location and extension (Westley/2W5/x1669)"

 +5        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               GOTO A1

           SET SDZPL=Y

 +6       ;

TIME      ; -- ask user for date/time to be ready

 +1        KILL DIR

           SET DIR(0)="DA^"_$$DAYS_"::EFT"

           SET DIR("B")=$$DAYSP

           SET DIR("?")=" "

 +2        SET DIR("?",1)="Enter the date@time you would like the charts to be ready."

 +3        SET DIR("?",2)="Please allow at least "_$$DAYSN_" days for charts to be pulled."

 +4        SET DIR("A")="DATE/TIME NEEDED:  "

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               GOTO A1

           IF Y<1

               GOTO A1

 +5       ;

 +6        SET SDZY=$SELECT(Y[".":Y,1:Y_".08")

           SET SDZYY=$PIECE(SDZY,".")

 +7       ;

PT        ; -- get patient

 +1        WRITE !!

           SET DIC="^DPT("

           SET DIC(0)="AEQMZ"

           DO ^DIC

           KILL DIC,I,J

           SET DFN=+Y

 +2        IF Y<0

               IF $DATA(SDMADE)

                   GOTO PRT

               IF '$DATA(SDMADE)

                   GOTO A1

 +3       ;

 +4        IF $SELECT('$DATA(^DPT(DFN,.35)):0,$PIECE(^(.35),U,1)]"":1,1:0)

               Begin DoDot:1

 +5                WRITE *7,!,"** PATIENT HAS DIED! **"

               End DoDot:1

 +6       ;

 +7        FOR SDPR=DT:0

               SET SDPR=$ORDER(^DPT(+Y,"S",SDPR))

               IF SDPR=""!(SDPR>(DT+.2400))

                   QUIT 

               Begin DoDot:1

 +8                IF $PIECE(^DPT(+Y,"S",SDPR,0),U,2)'["C"

                       IF $PIECE(^(0),U,2)'["N"

                           SET I(SDPR)=+^(0)

               End DoDot:1

 +9       ;

 +10       SET J=0

           FOR 

               SET J=$ORDER(^DPT(DFN,"DE",J))

               IF '$DATA(^(+J,0))

                   QUIT 

               IF $PIECE(^(0),U,2)'["I"

                   SET J(+^(0))=""

 +11       FOR SDPR=0:0

               SET SDPR=$ORDER(I(SDPR))

               IF SDPR=""

                   QUIT 

               Begin DoDot:1

 +12               FOR I=0:0

                       SET I=$ORDER(^SC(I(SDPR),"S",SDPR,1,I))

                       IF '$DATA(^(+I,0))

                           QUIT 

                       Begin DoDot:2

 +13                       IF ^SC(I(SDPR),"S",SDPR,1,I,0)-DFN=0

                               Begin DoDot:3

 +14                               DO GOT

                                   SET D=$PIECE(^DPT(DFN,0),U,2)="F"

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +15      ;

 +16       IF ('$DATA(J(SC)))&('$DATA(J(+$PIECE(^SC(SC,"SL"),U,5))))

               DO ENR

 +17      ;

 +18       SET Y=SDZY

           DO OKTD^SDI

           GOTO PT

 +19      ;

 +20      ;

ENR       ; -- enroll patient in clinic

 +1        SET Y=$PIECE(^SC(SC,"SL"),U,5)

           IF '$DATA(^SC(+Y,0))

               SET Y=+SC

 +2        SET Y=$PIECE(^SC(Y,0),U,1)

 +3        SET SDY=Y

           SET X="NOW"

           SET %DT="XT"

           DO ^%DT

           SET HEY=Y

 +4        SET DA=DFN

           SET DR="3///"_SDY

           SET (DIE,DIC)="^DPT("

           SET DP=2

 +5        SET DR(2,2.001)=".01///"_SDY_";1///"_HEY

 +6        SET DR(3,2.011)=".01///"_HEY_";1///O"

           DO ^DIE

           KILL DR

 +7        QUIT 

 +8       ;

GOT       ;W !,"REQUESTED FOR "_$E(SDPR_"000",9,12)_" ON "

 +1        SET SDMADE=""

           IF '$DATA(^SC(I(SDPR),"S",0))

               SET ^(0)="^44.001DA^^"

           QUIT 

 +2       ;

PRT       ; -- prints out routing slips for patients selected

 +1        IF $$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.14)="NO"

               GOTO END

 +2        KILL ASDCR,SDZPL

 +3        SET SDX="ADD"

           SET SDSP="N"

 +4        SET (SDIQ,DIV,SDHS,SDPP,APCHSTYP,SDAIU,SDREP)=""

           SET SDNFF=0

 +5        WRITE !!,"TO BYPASS PRINTING OF ROUTING SLIPS NOW - TYPE IN ^"

 +6        DO DIV^SDUTL

           IF $TEST

               DO ROUT^SDDIV

               IF Y<0

                   GOTO END

 +7        SET VAUTC=0

           SET VAUTC($PIECE(^SC(SC,0),U))=SC

           SET ORDER=2

           SET SDSTART=""

 +8        SET SDATE=SDZYY

 +9        SET APDATE=$EXTRACT(SDATE,4,5)_"/"_$EXTRACT(SDATE,6,7)_"/"_$EXTRACT(SDATE,2,3)

 +10       SET PRDATE=$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)

 +11       SET %ZIS="Q"

           SET %ZIS("B")=$$CRPTR

           DO ^%ZIS

 +12       IF POP

               GOTO END

           IF $DATA(IO("Q"))

               GOTO QUE

           DO START^SDROUT

           DO END

           QUIT 

 +13      ;

QUE       ;

 +1        KILL IO("Q"),ZTSAVE

 +2        FOR %="DIV","SDREP","SDSP","SDX","SDZPL","DUZ(2)","DT","SDSTART","SDATE","APDATE","PRDATE","SDIQ","YY","SDHS","SDPP","APCHSTYP","SDNFF","SDAIU","VAUTC(","VAUTC","ORDER"

               SET ZTSAVE(%)=""

 +3        SET ZTRTN="START^SDROUT"

           SET ZTDESC="ROUTING SLIPS"

 +4        DO ^%ZTLOAD

           KILL ZTSK

           DO HOME^%ZIS

           GOTO END

 +5       ;

END        KILL %,%DT,APCHSTYP,D,DA,DFN,DIC,DIE,DP,DR,GDATE,I,SDZY,J,PRDATE,SDATE

 +1        KILL SDHS,SDAIU,SDNFF,SDPP,SC,SD,SDAPTYP,SDD,SDINP,SDIQ,SDPL,SDPR,SDRT

 +2        KILL SDSC,SDSL,SDTTM,SDY,SDX,SDZPL,X,Y,Y1,SDMADE,ASDCR,YY,SDZYY

 +3        DO END^SDROUT1

 +4        QUIT 

 +5       ;

DAYS()    ; -- returns default first date for charts to be ready

 +1        NEW X1,X2,X

 +2        SET X1=DT

           SET X2=$$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.07)

 +3        IF X2=""

               SET X2=3

           DO C^%DTC

 +4        QUIT X_".0800"

 +5       ;

DAYSP()   ; -- return default day in readable format

 +1        QUIT $$FMTE^XLFDT($$DAYS,2)

 +2       ;

 +3       ;

DAYSN()   ; -- returns default # of days

 +1        QUIT $$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.07)

 +2       ;

CRPTR()   ; -- returns default chart request printer

 +1        QUIT $$VAL^XBDIQ1(40.8,$$DIV^ASDUT,9999999.05)