ADGPCAC6.m

ADGPCAC6 ; IHS/ADC/PDW/ENM - ADT/PCC DATA ENTRY-PROBLEMS ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;

A ; -- driver

 D L6 Q

 ;

L6 ; -- loop problems

 N IFN,N,X,X1

 Q:'$D(^AUPNPROB("AC",DFN))

 W @IOF," (6) ACTIVE Problems"

 S IFN=0 F  S IFN=$O(^AUPNPROB("AC",DFN,IFN)) Q:'IFN  D 6 Q:$D(DIRUT)

 Q:$D(DIRUT)  D Q Q

 ;

6 ; -- display active problems

 Q:'$D(^AUPNPROB(IFN,0))  S N=^(0)  Q:$P(N,U,12)'="A"

 W !?13,"Problem #: ",$$PRB

 W ?45,"Date: ",$$DT,!?13,"Narrative: ",$$NAR

 ; -- notes

 Q:'$O(^AUPNPROB(IFN,11,0))  W !?17,"Notes: "

 S X=0 F  S X=$O(^AUPNPROB(IFN,11,X)) Q:'X  D

 . S X1=0 F  S X1=$O(^AUPNPROB(IFN,11,X,11,X1)) Q:'X1  D

 .. W ?28,$P(^AUPNPROB(IFN,11,X,11,X1,0),U,3),!

PG ; -- form feed?

 W ! Q:($Y+4)'>IOSL  K DIR S DIR(0)="E" D ^DIR K DIR W @IOF Q

 ;

Q ; -- cleanup

 K DIR W ! S DIR(0)="E" D ^DIR K DIR,X W @IOF Q

 ;

PRB() ; -- problem number

 Q $P($G(^AUTTLOC(+$P(N,U,6),0)),U,7)_$P(N,U,7)

 ;

DT() ; -- date

 N X S X=$P(N,U,3) Q:'X ""  Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)

 ;

NAR() ; -- narrative

 Q $P($G(^AUTNPOV(+$P(N,U,5),0)),U)

ADGPCAC6  ; IHS/ADC/PDW/ENM - ADT/PCC DATA ENTRY-PROBLEMS ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

A         ; -- driver

 +1        DO L6

           QUIT 

 +2       ;

L6        ; -- loop problems

 +1        NEW IFN,N,X,X1

 +2        IF '$DATA(^AUPNPROB("AC",DFN))

               QUIT 

 +3        WRITE @IOF," (6) ACTIVE Problems"

 +4        SET IFN=0

           FOR 

               SET IFN=$ORDER(^AUPNPROB("AC",DFN,IFN))

               IF 'IFN

                   QUIT 

               DO 6

               IF $DATA(DIRUT)

                   QUIT 

 +5        IF $DATA(DIRUT)

               QUIT 

           DO Q

           QUIT 

 +6       ;

6         ; -- display active problems

 +1        IF '$DATA(^AUPNPROB(IFN,0))

               QUIT 

           SET N=^(0)

           IF $PIECE(N,U,12)'="A"

               QUIT 

 +2        WRITE !?13,"Problem #: ",$$PRB

 +3        WRITE ?45,"Date: ",$$DT,!?13,"Narrative: ",$$NAR

 +4       ; -- notes

 +5        IF '$ORDER(^AUPNPROB(IFN,11,0))

               QUIT 

           WRITE !?17,"Notes: "

 +6        SET X=0

           FOR 

               SET X=$ORDER(^AUPNPROB(IFN,11,X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +7                SET X1=0

                   FOR 

                       SET X1=$ORDER(^AUPNPROB(IFN,11,X,11,X1))

                       IF 'X1

                           QUIT 

                       Begin DoDot:2

 +8                        WRITE ?28,$PIECE(^AUPNPROB(IFN,11,X,11,X1,0),U,3),!

                       End DoDot:2

               End DoDot:1

PG        ; -- form feed?

 +1        WRITE !

           IF ($Y+4)'>IOSL

               QUIT 

           KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           WRITE @IOF

           QUIT 

 +2       ;

Q         ; -- cleanup

 +1        KILL DIR

           WRITE !

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR,X

           WRITE @IOF

           QUIT 

 +2       ;

PRB()     ; -- problem number

 +1        QUIT $PIECE($GET(^AUTTLOC(+$PIECE(N,U,6),0)),U,7)_$PIECE(N,U,7)

 +2       ;

DT()      ; -- date

 +1        NEW X

           SET X=$PIECE(N,U,3)

           IF 'X

               QUIT ""

           QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)

 +2       ;

NAR()     ; -- narrative

 +1        QUIT $PIECE($GET(^AUTNPOV(+$PIECE(N,U,5),0)),U)