Routine: SDROUT2

SDROUT2 ;BSN/GRR - PRINT ROUTING SLIPS HEADING ;4/24/01 3:10pm

 ;;5.3;Scheduling;**28,377,441,586**;Aug 13, 1993;Build 28

 ; Reference to $$IMP^ICDEX supported by ICR #5747

HED N LL,NAME,SDX,SSN,Y,ADDR

 N ICD10IMPDT ;SSA ICD-10

 W !,@IOF,"*** FACILITY: ",$S($D(^DG(40.8,+DIV,0)):$P(^(0),"^"),1:$P($$SITE^VASITE,U,2)) S P=P+1

 I ORDER=2 W !,"*** CLINIC: ",$P(^SC(+SC,0),"^")

 I ORDER=3 W !,"*** PHYSICAL LOCATION: "_I

 I $D(^DPT(J,.321)) F SDX1=1,2,3 I $P(^(.321),"^",SDX1)["Y" Q

 ;I  W ?45,"*** EXPOSURE SURVEY ***",!

 ;I $D(^DPT(J,.321)) F SDX1=1,2,3 I $P(^(.321),"^",SDX1)=""!($P(^(.321),"^",SDX1)["U") W ?45,"*** UPDATE SURVEY DATA ***" Q

 ;I '$D(^DPT(J,.321)) W ?45,"*** UPDATE SURVEY DATA ***"

 I P'>1 S SDZ="",$P(SDZ,"* ",13)="" D WCAT K SDZ

 W !,"PAGE ",P,?10,"OUTPATIENT ROUTING SLIP"

 I $D(^DPT(J,.36)),$P(^DPT(J,.36),"^",1)]""

 W ?45,"*** ",$S($T:$P(^DIC(8,+^DPT(J,.36),0),"^",1),1:"ELIG NOT SPECIFIED")," ***"

 S Y=^DPT(J,0),NAME=$P(Y,"^",1),SSN=$P(Y,"^",9)

 W !!,NAME,?54,"APPOINTMENT DATE"

 W !,$E(SSN,1,3),"-",$E(SSN,4,5),"-",$E(SSN,6,10),?58,APDATE

 I $D(^DPT(J,.1)) W !!,"*** INPATIENT ***",!,"LOCATED ON WARD: ",$P(^DPT(J,.1),"^",1),! G OVR

 S ADDR=$S($D(^DPT(J,.11)):^DPT(J,.11),1:"")

 F LL=1:1:3 W:$P(ADDR,"^",LL)]"" !,$P(ADDR,"^",LL)

 ; retrieve country info -- PERM country is piece 10 of .11

 N FILE,CNTRY,FORIEN,FOREIGN

 S FILE=779.004,FORIEN=$P(ADDR,U,10),CNTRY=$$GET1^DIQ(FILE,FORIEN_",",2),CNTRY=$$UPPER^VALM1(CNTRY),FOREIGN=$$FORIEN^DGADDUTL(FORIEN)

 I 'FOREIGN D

 . N SDZIP S SDZIP=$P(ADDR,U,12) S:$E(SDZIP,6,10)'="" SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,10)

 . W !,$P(ADDR,U,4)_", "_$P($G(^DIC(5,+$P(ADDR,U,5),0)),U)_"  "_SDZIP

 E  D

 . W !,$P(ADDR,U,9)_" "_$P(ADDR,U,4)_" "_$P(ADDR,U,8)

 W:CNTRY'="" !,CNTRY

 ;W !,$S($P(ADDR,"^",4)]"":$P(ADDR,"^",4),1:"")," ",$S($P(ADDR,"^",5)]"":$P(^DIC(5,+$P(ADDR,"^",5),0),"^",1),1:"")," ",$S($P(ADDR,"^",6)]"":$P(ADDR,"^",6),1:"")

 W !!,"PSA: UNKNOWN"

OVR W !

 N I S DFN=J D DIS

 N DGINSDT S DGINSDT=SDATE

 D INS^DGRPDB,KVAR^VADPT S J=DFN

 W ! Q

WCAT N DGMT S DGMT=$$LST^DGMTCOU1(J,"",3) Q:DGMT']""  S SDVA=$P(DGMT,U,3) I SDVA']"" Q  ;Q:$S('$D(^DG(41.3,+J,0)):1,$P(^(0),"^",2)']"":1,1:0)

 S SDVA=$S($P(DGMT,U,4)="R":"REQUIRES MEANS TEST",$P(DGMT,U,4)="N":"MEANS TEST NOT REQUIRED",1:SDVA)

 D KVAR^VADATE I $P(DGMT,U,2)]"",$P(DGMT,U,4)'="R",$P(DGMT,U,4)'="N" S VADAT("W")=$P(DGMT,U,2) D ^VADATE ;$N(^DG(41.3,+J,2,0))>0 S VADAT("W")=9999999-$N(^DG(41.3,J,2,0)) D ^VADATE

 W !?27,SDZ,!?27,$S($P(DGMT,U,5)=1:SDVA,1:"PHARMACY CO-PAY: "_SDVA) I $D(VADATE("E")) W !?27,"LAST TEST: ",VADATE("E")

 W !?27,SDZ K VADAT,VADATE,SDVA Q

HD W !,?11,"**CURRENT APPOINTMENTS**",!!,?3,"TIME",?11,"CLINIC",?45,"LOCATION",!

SCCOND ;  - text on routing sheet for determining if care for sc condition.

 S SDSCCOND=""

 ;SSA ICD-10

 N ICD10IMPDT S ICD10IMPDT=$$IMP^ICDEX(30)

 W !!?11,"List diagnosis "_$S(SDATE<ICD10IMPDT:"(ICD9)",1:"(ICD10)")_" ________________________________________________"

 W !!?11,"List any procedures performed during this clinic visit ________",!!?11,"_______________________________________________________________"

 D CL(J)

 W ! Q

CL(DFN) ;Classification

 N SDCLY,SDCTI,SDCTIS,SDCTS

 D CL^SDCO21(DFN,DT,"",.SDCLY) G CLQ:'$D(SDCLY)

 S SDCTIS=$$SEQ^SDCO21

W !

 F SDCTS=1:1 S SDCTI=+$P(SDCTIS,",",SDCTS) Q:'SDCTI  I $D(SDCLY(SDCTI)) D

 .W !,$P($G(^SD(409.41,SDCTI,0)),"^",2),"? "

 .W "__Yes __No"

CLQ Q

DIS ;rated disabilities

 ; -- Pharmacy is allowed to call this tag via a special agreement

 ;    with MAS.  MAS should notify pharmacy developers of any

 ;    changes that may impact PS* code.  (5/91 - MJK/BOK)

 I '$D(VAEL) D ELIG^VADPT S DGKVAR=1

 W:'+VAEL(3) !!,"Service Connected: NO" W:+VAEL(3) !!,"       SC Percent: ",$P(VAEL(3),"^",2)_"%"

 W !,"     Disabilities: " I 'VAEL(4),$S('$D(^DG(391,+VAEL(6),0)):1,$P(^(0),"^",2):0,1:1) W "NOT A VETERAN" G DISQ

 S I3=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I  D DIS1

 I 'I3 W $S('$O(^DPT(DFN,.372,0)):"NONE STATED",1:"NO SC DISABILITIES LISTED")

DISQ I $D(DGKVAR) D KVAR^VADPT K DGKVAR,I1,I2,I3

DIS1 S I1=^DPT(DFN,.372,I,0) I $P(I1,"^",3) S I2=$S($D(^DIC(31,+I1,0)):^(0),1:""),I2=$S($P(I2,"^",4)]"":$P(I2,"^",4),1:$P(I2,"^")) W !,I2,?48,$J($P(I1,"^",2),4),"% - ",$S($P(I1,"^",3):"SERVICE CONNECTED",1:"") S I3=I3+1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDROUT2   4336     printed  Mar 13, 2025@22:05:17                                                                                                                                                                                                     Page 2

SDROUT2   ;BSN/GRR - PRINT ROUTING SLIPS HEADING ;4/24/01 3:10pm

 +1       ;;5.3;Scheduling;**28,377,441,586**;Aug 13, 1993;Build 28

 +2       ;

 +3       ; Reference to $$IMP^ICDEX supported by ICR #5747

 +4       ;

HED        NEW LL,NAME,SDX,SSN,Y,ADDR

 +1       ;SSA ICD-10

           NEW ICD10IMPDT

 +2        WRITE !,@IOF,"*** FACILITY: ",$SELECT($DATA(^DG(40.8,+DIV,0)):$PIECE(^(0),"^"),1:$PIECE($$SITE^VASITE,U,2))

           SET P=P+1

 +3        IF ORDER=2

               WRITE !,"*** CLINIC: ",$PIECE(^SC(+SC,0),"^")

 +4        IF ORDER=3

               WRITE !,"*** PHYSICAL LOCATION: "_I

 +5        IF $DATA(^DPT(J,.321))

               FOR SDX1=1,2,3

                   IF $PIECE(^(.321),"^",SDX1)["Y"

                       QUIT

 +6       ;I  W ?45,"*** EXPOSURE SURVEY ***",!

 +7       ;I $D(^DPT(J,.321)) F SDX1=1,2,3 I $P(^(.321),"^",SDX1)=""!($P(^(.321),"^",SDX1)["U") W ?45,"*** UPDATE SURVEY DATA ***" Q

 +8       ;I '$D(^DPT(J,.321)) W ?45,"*** UPDATE SURVEY DATA ***"

 +9        IF P'>1

               SET SDZ=""

               SET $PIECE(SDZ,"* ",13)=""

               DO WCAT

               KILL SDZ

 +10       WRITE !,"PAGE ",P,?10,"OUTPATIENT ROUTING SLIP"

 +11       IF $DATA(^DPT(J,.36))

               IF $PIECE(^DPT(J,.36),"^",1)]""

 +12       WRITE ?45,"*** ",$SELECT($TEST:$PIECE(^DIC(8,+^DPT(J,.36),0),"^",1),1:"ELIG NOT SPECIFIED")," ***"

 +13       SET Y=^DPT(J,0)

           SET NAME=$PIECE(Y,"^",1)

           SET SSN=$PIECE(Y,"^",9)

 +14       WRITE !!,NAME,?54,"APPOINTMENT DATE"

 +15       WRITE !,$EXTRACT(SSN,1,3),"-",$EXTRACT(SSN,4,5),"-",$EXTRACT(SSN,6,10),?58,APDATE

 +16       IF $DATA(^DPT(J,.1))

               WRITE !!,"*** INPATIENT ***",!,"LOCATED ON WARD: ",$PIECE(^DPT(J,.1),"^",1),!

               GOTO OVR

 +17       SET ADDR=$SELECT($DATA(^DPT(J,.11)):^DPT(J,.11),1:"")

 +18       FOR LL=1:1:3

               if $PIECE(ADDR,"^",LL)]""

                   WRITE !,$PIECE(ADDR,"^",LL)

 +19      ; retrieve country info -- PERM country is piece 10 of .11

 +20       NEW FILE,CNTRY,FORIEN,FOREIGN

 +21       SET FILE=779.004

           SET FORIEN=$PIECE(ADDR,U,10)

           SET CNTRY=$$GET1^DIQ(FILE,FORIEN_",",2)

           SET CNTRY=$$UPPER^VALM1(CNTRY)

           SET FOREIGN=$$FORIEN^DGADDUTL(FORIEN)

 +22       IF 'FOREIGN

               Begin DoDot:1

 +23               NEW SDZIP

                   SET SDZIP=$PIECE(ADDR,U,12)

                   if $EXTRACT(SDZIP,6,10)'=""

                       SET SDZIP=$EXTRACT(SDZIP,1,5)_"-"_$EXTRACT(SDZIP,6,10)

 +24               WRITE !,$PIECE(ADDR,U,4)_", "_$PIECE($GET(^DIC(5,+$PIECE(ADDR,U,5),0)),U)_"  "_SDZIP

               End DoDot:1

 +25      IF '$TEST

               Begin DoDot:1

 +26               WRITE !,$PIECE(ADDR,U,9)_" "_$PIECE(ADDR,U,4)_" "_$PIECE(ADDR,U,8)

               End DoDot:1

 +27       if CNTRY'=""

               WRITE !,CNTRY

 +28      ;W !,$S($P(ADDR,"^",4)]"":$P(ADDR,"^",4),1:"")," ",$S($P(ADDR,"^",5)]"":$P(^DIC(5,+$P(ADDR,"^",5),0),"^",1),1:"")," ",$S($P(ADDR,"^",6)]"":$P(ADDR,"^",6),1:"")

 +29       WRITE !!,"PSA: UNKNOWN"

OVR        WRITE !

 +1        NEW I

           SET DFN=J

           DO DIS

 +2        NEW DGINSDT

           SET DGINSDT=SDATE

 +3        DO INS^DGRPDB

           DO KVAR^VADPT

           SET J=DFN

 +4        WRITE !

           QUIT

WCAT      ;Q:$S('$D(^DG(41.3,+J,0)):1,$P(^(0),"^",2)']"":1,1:0)

           NEW DGMT

           SET DGMT=$$LST^DGMTCOU1(J,"",3)

           if DGMT']""

               QUIT

           SET SDVA=$PIECE(DGMT,U,3)

           IF SDVA']""

               QUIT

 +1        SET SDVA=$SELECT($PIECE(DGMT,U,4)="R":"REQUIRES MEANS TEST",$PIECE(DGMT,U,4)="N":"MEANS TEST NOT REQUIRED",1:SDVA)

 +2       ;$N(^DG(41.3,+J,2,0))>0 S VADAT("W")=9999999-$N(^DG(41.3,J,2,0)) D ^VADATE

           DO KVAR^VADATE

           IF $PIECE(DGMT,U,2)]""

               IF $PIECE(DGMT,U,4)'="R"

                   IF $PIECE(DGMT,U,4)'="N"

                       SET VADAT("W")=$PIECE(DGMT,U,2)

                       DO ^VADATE

 +3        WRITE !?27,SDZ,!?27,$SELECT($PIECE(DGMT,U,5)=1:SDVA,1:"PHARMACY CO-PAY: "_SDVA)

           IF $DATA(VADATE("E"))

               WRITE !?27,"LAST TEST: ",VADATE("E")

 +4        WRITE !?27,SDZ

           KILL VADAT,VADATE,SDVA

           QUIT

HD         WRITE !,?11,"**CURRENT APPOINTMENTS**",!!,?3,"TIME",?11,"CLINIC",?45,"LOCATION",!

 +1        QUIT

SCCOND    ;  - text on routing sheet for determining if care for sc condition.

 +1        SET SDSCCOND=""

 +2       ;SSA ICD-10

 +3        NEW ICD10IMPDT

           SET ICD10IMPDT=$$IMP^ICDEX(30)

 +4        WRITE !!?11,"List diagnosis "_$SELECT(SDATE<ICD10IMPDT:"(ICD9)",1:"(ICD10)")_" ________________________________________________"

 +5        WRITE !!?11,"List any procedures performed during this clinic visit ________",!!?11,"_______________________________________________________________"

 +6        DO CL(J)

 +7        WRITE !

           QUIT

 +8       ;

CL(DFN)   ;Classification

 +1        NEW SDCLY,SDCTI,SDCTIS,SDCTS

 +2        DO CL^SDCO21(DFN,DT,"",.SDCLY)

           if '$DATA(SDCLY)

               GOTO CLQ

 +3        SET SDCTIS=$$SEQ^SDCO21

 +4        WRITE !

 +5        FOR SDCTS=1:1

               SET SDCTI=+$PIECE(SDCTIS,",",SDCTS)

               if 'SDCTI

                   QUIT

               IF $DATA(SDCLY(SDCTI))

                   Begin DoDot:1

 +6                    WRITE !,$PIECE($GET(^SD(409.41,SDCTI,0)),"^",2),"? "

 +7                    WRITE "__Yes __No"

                   End DoDot:1

CLQ        QUIT

 +1       ;

DIS       ;rated disabilities

 +1       ; -- Pharmacy is allowed to call this tag via a special agreement

 +2       ;    with MAS.  MAS should notify pharmacy developers of any

 +3       ;    changes that may impact PS* code.  (5/91 - MJK/BOK)

 +4       ;

 +5        IF '$DATA(VAEL)

               DO ELIG^VADPT

               SET DGKVAR=1

 +6        if '+VAEL(3)

               WRITE !!,"Service Connected: NO"

           if +VAEL(3)

               WRITE !!,"       SC Percent: ",$PIECE(VAEL(3),"^",2)_"%"

 +7        WRITE !,"     Disabilities: "

           IF 'VAEL(4)

               IF $SELECT('$DATA(^DG(391,+VAEL(6),0)):1,$PIECE(^(0),"^",2):0,1:1)

                   WRITE "NOT A VETERAN"

                   GOTO DISQ

 +8        SET I3=0

           FOR I=0:0

               SET I=$ORDER(^DPT(DFN,.372,I))

               if 'I

                   QUIT

               DO DIS1

 +9        IF 'I3

               WRITE $SELECT('$ORDER(^DPT(DFN,.372,0)):"NONE STATED",1:"NO SC DISABILITIES LISTED")

DISQ       IF $DATA(DGKVAR)

               DO KVAR^VADPT

               KILL DGKVAR,I1,I2,I3

 +1        QUIT

DIS1       SET I1=^DPT(DFN,.372,I,0)

           IF $PIECE(I1,"^",3)

               SET I2=$SELECT($DATA(^DIC(31,+I1,0)):^(0),1:"")

               SET I2=$SELECT($PIECE(I2,"^",4)]"":$PIECE(I2,"^",4),1:$PIECE(I2,"^"))

               WRITE !,I2,?48,$JUSTIFY($PIECE(I1,"^",2),4),"% - ",$SELECT($PIECE(I1,"^",3):"SERVICE CONNECTED",1:"")

               SET I3=I3+1

 +1        QUIT

SDROUT2.m