Routine: ACHSUD1

ACHSUD1 ; IHS/ITSC/PMF - SELECT HOSPITAL ORDER NUMBER ;   [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 K ACHSDIEN,DIC

A1 ;

 W !!,"Hospital Order Number: "

 W:ACHSHONN]"" ACHSHONN_"// "

 D READ^ACHSFU

 I Y?1"?".E D ORD G A1

 Q:$D(DUOUT)!(Y="")

 I Y=" ",$D(^DISV(DUZ,"ACHSUD1")) S Y=$G(^DISV(DUZ,"ACHSUD1")),Y=$E(Y,2)_"-"_$E(Y,3,99) W Y

 I ACHSHONN]"",Y="@" W "   Deleted" S (ACHSHON,ACHSHONN)="" G A1

 G END:Y=""

 F %=1:1:$L(Y) I $E(Y,%)?1P,$E(Y,%)'="-" S Y=$E(Y,1,%-1)_"-"_$E(Y,%+1,999)

 F  S F=$F(Y,"--") Q:'F  S Y=$P(Y,"--")_"-"_$P(Y,"--",2,999)

 S (N,F,C)="",P=$L(Y,"-")

 I P>3 W *7,"  ??" G A1

 S N=$P(Y,"-",P)

 I P=3 S F=$P(Y,"-",2),C=+Y G A2

 I P=2 S C=$P(Y,"-") S:$L(C)>1 F=C,C=""

A2 ;

 S:C="" C=$E(ACHSACFY,4)

 S:F="" F=ACHSFC

 I $L(F)<3 S F=$E("000",1,3-$L(F))_F

 I $L(N)<6 S N=$E("00000",1,5-$L(N))_N

 S X="1"_C_N

 K C,F,N,P

 S DIC="^ACHSF("_DUZ(2)_",""D"",",DIC(0)="QZE",DIC("W")="W ""  "",$P(^(0),U,14),""-"",ACHSFC,""-"",$P(^(0),U)"

 D ^DIC

 K DIC

 G A1:Y<1

 S ACHSHON=+Y,^DISV(DUZ,"ACHSUD1")=$P(Y,U,2)

END ;

ORD ;

 W !!,"  If The Patient Is Currently Being Hospitialized Under Contract",!,"  Enter The Order Number.  Enter An '@' To Delete The Current Number.",!

 Q:'$G(DFN)

ORDC ; Check Inpatient Hospital Order Number.

K O

 S (A,E)=0

 F  S A=$O(^ACHSF(DUZ(2),"PB",DFN,A)) Q:'A  I $D(^ACHSF(DUZ(2),"D",A,0)),$P(^(0),U,4)=1 S E=E+1,O(E)=+A_U_^(0)

 G:'$D(O) ENDO

 W !?8,"Doc #",?25,"Tran Date",!

 F E=1:1 S A=$O(O(A)) Q:A<1  D

 . W !,E,".",?5,$P(O(A),U,15),"-",ACHSFC,"-",$P(O(A),U,2),?25,$$FMTE^XLFDT($P(O(A),U,3))

 . S $P(O(A),U,2)=$P(O(A),U,15)_"-"_ACHSFC_"-"_$P(O(A),U,2)

.Q

 S Y=$$DIR^XBDIR("NO^1:"_(E-1),"Hospital Order Number","","","","",2)

 G ENDO:$D(DUOUT)!$D(DTOUT)

 I Y="" S (ACHSHON,ACHSHONN)="" G ENDO

 S:$D(O(Y)) ACHSHON=+O(Y)

 W " ",$P(O(Y),U,2)

 S ACHSHONN=$P(O(Y),U,2)

ENDO ;

 K A,E,O

ACHSUD1   ; IHS/ITSC/PMF - SELECT HOSPITAL ORDER NUMBER ;   [ 10/16/2001   8:16 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 +2       ;

 +3        KILL ACHSDIEN,DIC

A1        ;

 +1        WRITE !!,"Hospital Order Number: "

 +2        IF ACHSHONN]""

               WRITE ACHSHONN_"// "

 +3        DO READ^ACHSFU

 +4        IF Y?1"?".E

               DO ORD

               GOTO A1

 +5        IF $DATA(DUOUT)!(Y="")

               QUIT

 +6        IF Y=" "

               IF $DATA(^DISV(DUZ,"ACHSUD1"))

                   SET Y=$GET(^DISV(DUZ,"ACHSUD1"))

                   SET Y=$EXTRACT(Y,2)_"-"_$EXTRACT(Y,3,99)

                   WRITE Y

 +7        IF ACHSHONN]""

               IF Y="@"

                   WRITE "   Deleted"

                   SET (ACHSHON,ACHSHONN)=""

                   GOTO A1

 +8        IF Y=""

               GOTO END

 +9        FOR %=1:1:$LENGTH(Y)

               IF $EXTRACT(Y,%)?1P

                   IF $EXTRACT(Y,%)'="-"

                       SET Y=$EXTRACT(Y,1,%-1)_"-"_$EXTRACT(Y,%+1,999)

 +10       FOR

               SET F=$FIND(Y,"--")

               IF 'F

                   QUIT

               SET Y=$PIECE(Y,"--")_"-"_$PIECE(Y,"--",2,999)

 +11       SET (N,F,C)=""

           SET P=$LENGTH(Y,"-")

 +12       IF P>3

               WRITE *7,"  ??"

               GOTO A1

 +13       SET N=$PIECE(Y,"-",P)

 +14       IF P=3

               SET F=$PIECE(Y,"-",2)

               SET C=+Y

               GOTO A2

 +15       IF P=2

               SET C=$PIECE(Y,"-")

               IF $LENGTH(C)>1

                   SET F=C

                   SET C=""

A2        ;

 +1        IF C=""

               SET C=$EXTRACT(ACHSACFY,4)

 +2        IF F=""

               SET F=ACHSFC

 +3        IF $LENGTH(F)<3

               SET F=$EXTRACT("000",1,3-$LENGTH(F))_F

 +4        IF $LENGTH(N)<6

               SET N=$EXTRACT("00000",1,5-$LENGTH(N))_N

 +5        SET X="1"_C_N

 +6        KILL C,F,N,P

 +7        SET DIC="^ACHSF("_DUZ(2)_",""D"","

           SET DIC(0)="QZE"

           SET DIC("W")="W ""  "",$P(^(0),U,14),""-"",ACHSFC,""-"",$P(^(0),U)"

 +8        DO ^DIC

 +9        KILL DIC

 +10       IF Y<1

               GOTO A1

 +11       SET ACHSHON=+Y

           SET ^DISV(DUZ,"ACHSUD1")=$PIECE(Y,U,2)

END       ;

 +1        QUIT

 +2       ;

ORD       ;

 +1        WRITE !!,"  If The Patient Is Currently Being Hospitialized Under Contract",!,"  Enter The Order Number.  Enter An '@' To Delete The Current Number.",!

 +2        IF '$GET(DFN)

               QUIT

ORDC      ; Check Inpatient Hospital Order Number.

 +1        KILL O

 +2        SET (A,E)=0

 +3        FOR

               SET A=$ORDER(^ACHSF(DUZ(2),"PB",DFN,A))

               IF 'A

                   QUIT

               IF $DATA(^ACHSF(DUZ(2),"D",A,0))

                   IF $PIECE(^(0),U,4)=1

                       SET E=E+1

                       SET O(E)=+A_U_^(0)

 +4        IF '$DATA(O)

               GOTO ENDO

 +5        WRITE !?8,"Doc #",?25,"Tran Date",!

 +6        FOR E=1:1

               SET A=$ORDER(O(A))

               IF A<1

                   QUIT

               Begin DoDot:1

 +7                WRITE !,E,".",?5,$PIECE(O(A),U,15),"-",ACHSFC,"-",$PIECE(O(A),U,2),?25,$$FMTE^XLFDT($PIECE(O(A),U,3))

 +8                SET $PIECE(O(A),U,2)=$PIECE(O(A),U,15)_"-"_ACHSFC_"-"_$PIECE(O(A),U,2)

 +9                QUIT

               End DoDot:1

 +10       SET Y=$$DIR^XBDIR("NO^1:"_(E-1),"Hospital Order Number","","","","",2)

 +11       IF $DATA(DUOUT)!$DATA(DTOUT)

               GOTO ENDO

 +12       IF Y=""

               SET (ACHSHON,ACHSHONN)=""

               GOTO ENDO

 +13       IF $DATA(O(Y))

               SET ACHSHON=+O(Y)

 +14       WRITE " ",$PIECE(O(Y),U,2)

 +15       SET ACHSHONN=$PIECE(O(Y),U,2)

ENDO      ;

 +1        KILL A,E,O

 +2        QUIT

 +3       ;

ACHSUD1.m