- ABPAALK1 ;PRIV-INS ACCOUNT DISPLAY UTILITY; [ 05/22/91 12:37 PM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- PAT D XIT
- S ABPA("HD",1)=ABPATLE
- S ABPA("HD",2)="Display ALL Patient TRANSACTIONS" D ^ABPAHD
- W !! D ^ABPAPATL I $D(ABPATDFN)'=1 D XIT Q
- I +ABPATDFN<1 G PAT
- ;---------------------------------------------------------------------
- DEVICE ;PROCEDURE TO PROCESS OUTPUT DEVICE SELECTION
- K %IS S %IS="H",%IS("A")="Use which device: " W ! D ^%ZIS U IO
- ;---------------------------------------------------------------------
- I IO'=IO(0) U IO(0) W ! D WAIT^DICD U IO
- DT0 S $P(ABPAX,"=",80)="",ABPAHRN=$P(^ABPVAO(ABPATDFN,0),"^",3)
- S ABPAL=$E($P(^DIC(4,$P(^ABPVAO(DA,0),U,2),0),U),1,25)
- S $P(ABPAXX,"-",80)="" D ^ABPAALK3 S ABPAC=0
- OPEN F ABPAI=1:1 D Q:+ABPAC=0 K QFLG D DT3 G:$D(QFLG)=1 ENDLST
- .S ABPAC=$O(^ABPVAO("CS","O",ABPATDFN,ABPAC)) Q:+ABPAC=0
- S ABPAC=0
- PENDING F ABPAI=ABPAI:1 D Q:+ABPAC=0 K QFLG D DT3 G:$D(QFLG)=1 ENDLST
- .S ABPAC=$O(^ABPVAO("CS","PE",ABPATDFN,ABPAC)) Q:+ABPAC=0
- S ABPAC=0
- PAID D ^ABPAALK2
- G ENDLST
- ;
- DT3 S Y=^ABPVAO(DA,1,ABPAC,0),ABPA(ABPAI)=+Y
- S ABPAINS=$E($P(^AUTNINS($P(Y,U,6),0),U),1,15)
- W !,$J(ABPAI,2),?5,$J("",14-$L(ABPAINS)\2)_ABPAINS,?22,$J((+$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_+$E(Y,2,3)),8),?33,$J($P(Y,U,7),8,2)
- S ABPASTAT=$P(Y,"^",17)
- W ?43,ABPASTAT,$S(ABPASTAT="C":"LOSED",ABPASTAT="D":"ENIED",ABPASTAT="PA":"ID",ABPASTAT="PE":"NDING",ABPASTAT="O":"PEN",1:"??????")
- LOOP I ABPASTAT="PA"!(ABPASTAT="C") S R=0,CNT=0 F I=1:1 D Q:+R=0
- .S R=$O(^ABPVAO(DA,"P",R)) Q:+R=0 S RR=0 F I=1:1 D Q:+RR=0
- ..S RR=$O(^ABPVAO(DA,"P",R,"D",RR)) Q:+RR=0
- ..Q:$D(^ABPVAO(DA,"P",R,"D",RR,0))'=1
- ..Q:+$P(^ABPVAO(DA,"P",R,"D",RR,0),"^",2)'=+ABPAC
- ..S ABPAPDT=+^ABPVAO(DA,"P",R,0)
- ..S ABPAPDT=$J((+$E(ABPAPDT,4,5)_"/"_+$E(ABPAPDT,6,7)_"/"_+$E(ABPAPDT,2,3)),10)
- ..S CNT=CNT+1 W:+CNT>1 ! W ?50,ABPAPDT S RR=0
- ..S RRR=0 F J=1:1 D Q:+RRR=0
- ...S RRR=$O(^ABPVAO(DA,"P",R,"A",RRR)) Q:+RRR=0
- ...Q:$D(^ABPVAO(DA,"P",R,"A",RRR,0))'=1
- ...W:+J>1 ! W ?62,$J(+^ABPVAO(DA,"P",R,"A",RRR,0),10,2)
- ...W " (",$P(^ABPVAO(DA,"P",R,"A",RRR,0),"^",2),")"
- K ABPA("STAT"),R,RR,CNT,I
- CONT I $Y>21&(IO=IO(0)) D Q:$D(QFLG)=1 D ^ABPAALK3
- .R !,?20,"< Press 'RETURN' to Continue, or '^' to Exit >",X:300
- .S:'$T!(X="^") QFLG=""
- I $Y>55 W @IOF
- Q
- ;
- ENDLST W:IO'=IO(0) @IOF X ^%ZIS("C")
- W ! S ABPAMESS="End of display...press any key to continue"
- D PAUSE^ABPAMAIN G PAT
- ;
- XIT K ABPARECV,ABPAPD,ABPAENT,ABPADDFN,ABPATDFN,ABPADT,ABPADTD,ABPAPAT,D
- K ABPA,ABPAL,DIC,C,ABPADT,ABPAQKS,ABPAQK,ABPAHRN,ABPARECV,DA,J,K,Z,XQH
- END K ABPAC,ABPAI,ABPAXX,ABPAINS,DIE,DR,%DT,ABPAX,ABPAZ,ABPAPDT,QFLG Q
- ABPAALK1 ;PRIV-INS ACCOUNT DISPLAY UTILITY; [ 05/22/91 12:37 PM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- PAT DO XIT
- +1 SET ABPA("HD",1)=ABPATLE
- +2 SET ABPA("HD",2)="Display ALL Patient TRANSACTIONS"
- DO ^ABPAHD
- +3 WRITE !!
- DO ^ABPAPATL
- IF $DATA(ABPATDFN)'=1
- DO XIT
- QUIT
- +4 IF +ABPATDFN<1
- GOTO PAT
- +5 ;---------------------------------------------------------------------
- DEVICE ;PROCEDURE TO PROCESS OUTPUT DEVICE SELECTION
- +1 KILL %IS
- SET %IS="H"
- SET %IS("A")="Use which device: "
- WRITE !
- DO ^%ZIS
- USE IO
- +2 ;---------------------------------------------------------------------
- +3 IF IO'=IO(0)
- USE IO(0)
- WRITE !
- DO WAIT^DICD
- USE IO
- DT0 SET $PIECE(ABPAX,"=",80)=""
- SET ABPAHRN=$PIECE(^ABPVAO(ABPATDFN,0),"^",3)
- +1 SET ABPAL=$EXTRACT($PIECE(^DIC(4,$PIECE(^ABPVAO(DA,0),U,2),0),U),1,25)
- +2 SET $PIECE(ABPAXX,"-",80)=""
- DO ^ABPAALK3
- SET ABPAC=0
- OPEN FOR ABPAI=1:1
- Begin DoDot:1
- +1 SET ABPAC=$ORDER(^ABPVAO("CS","O",ABPATDFN,ABPAC))
- IF +ABPAC=0
- QUIT
- End DoDot:1
- IF +ABPAC=0
- QUIT
- KILL QFLG
- DO DT3
- IF $DATA(QFLG)=1
- GOTO ENDLST
- +2 SET ABPAC=0
- PENDING FOR ABPAI=ABPAI:1
- Begin DoDot:1
- +1 SET ABPAC=$ORDER(^ABPVAO("CS","PE",ABPATDFN,ABPAC))
- IF +ABPAC=0
- QUIT
- End DoDot:1
- IF +ABPAC=0
- QUIT
- KILL QFLG
- DO DT3
- IF $DATA(QFLG)=1
- GOTO ENDLST
- +2 SET ABPAC=0
- PAID DO ^ABPAALK2
- +1 GOTO ENDLST
- +2 ;
- DT3 SET Y=^ABPVAO(DA,1,ABPAC,0)
- SET ABPA(ABPAI)=+Y
- +1 SET ABPAINS=$EXTRACT($PIECE(^AUTNINS($PIECE(Y,U,6),0),U),1,15)
- +2 WRITE !,$JUSTIFY(ABPAI,2),?5,$JUSTIFY("",14-$LENGTH(ABPAINS)\2)_ABPAINS,?22,$JUSTIFY((+$EXTRACT(Y,4,5)_"/"_+$EXTRACT(Y,6,7)_"/"_+$EXTRACT(Y,2,3)),8),?33,$JUSTIFY($PIECE(Y,U,7),8,2)
- +3 SET ABPASTAT=$PIECE(Y,"^",17)
- +4 WRITE ?43,ABPASTAT,$SELECT(ABPASTAT="C":"LOSED",ABPASTAT="D":"ENIED",ABPASTAT="PA":"ID",ABPASTAT="PE":"NDING",ABPASTAT="O":"PEN",1:"??????")
- LOOP IF ABPASTAT="PA"!(ABPASTAT="C")
- SET R=0
- SET CNT=0
- FOR I=1:1
- Begin DoDot:1
- +1 SET R=$ORDER(^ABPVAO(DA,"P",R))
- IF +R=0
- QUIT
- SET RR=0
- FOR I=1:1
- Begin DoDot:2
- +2 SET RR=$ORDER(^ABPVAO(DA,"P",R,"D",RR))
- IF +RR=0
- QUIT
- +3 IF $DATA(^ABPVAO(DA,"P",R,"D",RR,0))'=1
- QUIT
- +4 IF +$PIECE(^ABPVAO(DA,"P",R,"D",RR,0),"^",2)'=+ABPAC
- QUIT
- +5 SET ABPAPDT=+^ABPVAO(DA,"P",R,0)
- +6 SET ABPAPDT=$JUSTIFY((+$EXTRACT(ABPAPDT,4,5)_"/"_+$EXTRACT(ABPAPDT,6,7)_"/"_+$EXTRACT(ABPAPDT,2,3)),10)
- +7 SET CNT=CNT+1
- IF +CNT>1
- WRITE !
- WRITE ?50,ABPAPDT
- SET RR=0
- +8 SET RRR=0
- FOR J=1:1
- Begin DoDot:3
- +9 SET RRR=$ORDER(^ABPVAO(DA,"P",R,"A",RRR))
- IF +RRR=0
- QUIT
- +10 IF $DATA(^ABPVAO(DA,"P",R,"A",RRR,0))'=1
- QUIT
- +11 IF +J>1
- WRITE !
- WRITE ?62,$JUSTIFY(+^ABPVAO(DA,"P",R,"A",RRR,0),10,2)
- +12 WRITE " (",$PIECE(^ABPVAO(DA,"P",R,"A",RRR,0),"^",2),")"
- End DoDot:3
- IF +RRR=0
- QUIT
- End DoDot:2
- IF +RR=0
- QUIT
- End DoDot:1
- IF +R=0
- QUIT
- +13 KILL ABPA("STAT"),R,RR,CNT,I
- CONT IF $Y>21&(IO=IO(0))
- Begin DoDot:1
- +1 READ !,?20,"< Press 'RETURN' to Continue, or '^' to Exit >",X:300
- +2 IF '$TEST!(X="^")
- SET QFLG=""
- End DoDot:1
- IF $DATA(QFLG)=1
- QUIT
- DO ^ABPAALK3
- +3 IF $Y>55
- WRITE @IOF
- +4 QUIT
- +5 ;
- ENDLST IF IO'=IO(0)
- WRITE @IOF
- XECUTE ^%ZIS("C")
- +1 WRITE !
- SET ABPAMESS="End of display...press any key to continue"
- +2 DO PAUSE^ABPAMAIN
- GOTO PAT
- +3 ;
- XIT KILL ABPARECV,ABPAPD,ABPAENT,ABPADDFN,ABPATDFN,ABPADT,ABPADTD,ABPAPAT,D
- +1 KILL ABPA,ABPAL,DIC,C,ABPADT,ABPAQKS,ABPAQK,ABPAHRN,ABPARECV,DA,J,K,Z,XQH
- END KILL ABPAC,ABPAI,ABPAXX,ABPAINS,DIE,DR,%DT,ABPAX,ABPAZ,ABPAPDT,QFLG
- QUIT
