QANPSDO ;HISC/GJC Pseudo VA 10-2633 ; 10/1/92
;;2.0;Incident Reporting;**1,31**;08/07/1992
;
;CHOOSE PATIENT, THEN THE INCIDENT PUT INTO REPORT OPTION
;***QANDFN IS FILE 742'S IEN ***:*** QANIEN IS FILE 742.4'S IEN ***
PAT ;
S QANXIT=0 K DIR S DIR("A")="Do you wish to generate a blank 10-2633? "
S DIR(0)="YA",DIR("?")="Enter 'Y' for yes, 'N' for no."
D ^DIR K DIR G:$D(DIRUT)!($D(DIROUT)) KILL
S QANBLNK=+Y G:QANBLNK SETUP
K DIC S DIC="^QA(742,",DIC(0)="QEAMZ",DIC("A")="Select Patient: "
S DIC("S1")="I ""013""[+$P(^QA(742.4,+$P(^QA(742,+Y,0),U,3),0),U,8)"
S DIC("S2")="&('$D(^QA(742,""BPRS"",-1,+Y)))"
S DIC("S")=DIC("S1")_DIC("S2")
S DIC("W")="D DICW^QANUTL1",D="B^BS5" D MIX^DIC1 K D,DIC
I +Y=-1 S QANXIT=1 W !!,*7,"Patient not selected, exiting!!" G EXIT
PAT1 W !?5,Y(0,0)_" OK" S %=1 D YN^DICN G:%=2 PAT
S:%<0 QANXIT=1 W:QANXIT !!,*7,"Patient not selected, exiting!!" G:QANXIT EXIT
I %=0 W !!,*7,"Enter ""Y""es if the patient choice is correct, ""N""o if the patient choice is ",!,"incorrect.",! G PAT
S QANDFN=+Y,QANIEN=$P(Y(0),U,3),QANAME=Y(0,0)
I '$D(QANIEN)!('$D(QANDFN)) W !!,*7,"Incomplete data, exiting the report." Q
S QAN742=$G(^QA(742,QANDFN,0)),QAN7424=$G(^QA(742.4,QANIEN,0)),QANPAT=$P(QAN742,U) Q:+QANPAT<1
SETUP ;"Jump" here to set up vars for blank report, fall through for normal.
S QANHEAD="PATIENT INCIDENT WORKSHEET",PAGE=0,$P(QANEQ,"=",81)="",$P(QANEQ1,"-",81)="",QANFLAG=0
TASK ;Task off to a device.
S Y=DT X ^DD("DD") S TODAY=Y,QANFIN=""
;*** Choose device ***
K IOP,%ZIS S %ZIS("A")="Print on device: ",%ZIS="MQ" W ! D ^%ZIS W !!
G:POP KILL
I $D(IO("Q")) S ZTRTN="STRT^QANPSDO",ZTDESC="Generate Patient Incident Worksheet(s)." D QLOOP,^%ZTLOAD W !,$S($D(ZTSK):"Request queued!",1:"Request cancelled!"),! G EXIT
STRT ;
U IO D HDR G:QANBLNK BLANK
S QANAME=$P($P(^DPT(QANPAT,0),U),",",2)_" "_$P($P(^DPT(QANPAT,0),U),","),QANPID=$P(QAN742,U,2),QANSSN=$E($P(^DPT(QANPAT,0),U,9),1,3)_"-"_$E($P(^DPT(QANPAT,0),U,9),4,5)_"-"_$E($P(^DPT(QANPAT,0),U,9),6,9),QANCASE=$P(QAN7424,U)
S QANDOB=$P(^DPT(QANPAT,0),U,3),X=DT,X1=X,X2=QANDOB,X="" D:+X2>0 ^%DTC S X=X\365.25,QANAGE=X K X,X1,X2,QANDOB
K C,Y S Y=$P(QAN742,U,4),C=$P(^DD(742,.04,0),U,2) D:Y]"" Y^DIQ S QANADMT=Y K C,Y
K C,Y S Y=$P(QAN742,U,6),C=$P(^DD(742,.06,0),U,2) D:Y]"" Y^DIQ S QANWARD=Y K C,Y
K C,Y S Y=$P(QAN742,U,8),C=$P(^DD(742,.08,0),U,2) D:Y]"" Y^DIQ S QANSERV=Y K C,Y
K C,Y S Y=$P(QAN7424,U,2),C=$P(^DD(742.4,.02,0),U,2) D:Y]"" Y^DIQ S QANINCD=Y K C,Y
K C,Y S Y=$P(QAN7424,U,11),C=$P(^DD(742.4,.12,0),U,2) D:Y]"" Y^DIQ S QANLREV=Y K C,Y
K C,Y S Y=$P(QAN7424,U,4),C=$P(^DD(742.4,.04,0),U,2) D:Y]"" Y^DIQ S QANILOC=Y K C,Y
K C,Y S Y=$P(QAN7424,U,9),C=$P(^DD(742.4,.1,0),U,2) D:Y]"" Y^DIQ S QANINIT=Y K C,Y
K C,Y S Y=$P(QAN7424,U,3),C=$P(^DD(742.4,.03,0),U,2) D:Y]"" Y^DIQ S QANDATE=Y K C,Y
K C,Y S Y=$P(QAN742,U,10),C=$P(^DD(742,.1,0),U,2) D:Y]"" Y^DIQ S QANSLVL=Y K C,Y
K C,Y S Y=$P(QAN7424,U,7),C=$P(^DD(742.4,.08,0),U,2) D:Y]"" Y^DIQ S QANWIT=Y K C,Y
BLANK D ^QANPSD1 ; Do prints
I $E(IOST)'="C" F W ! W:$Y>(IOSL-4) "VA Form 10-2633" Q:$Y>(IOSL-4)
EXIT W ! D ^%ZISC,HOME^%ZIS
KILL ;Kill and Quit
K %T,%W,%Y,DTOUT,DUOUT,DIROUT,DIRUT,QANBLNK,QANLNCT
K %,%ZIS,BA,C,D,DIC,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,PAGE
K POP,QAN,QAN742,QAN7424,QANADMT,QANAGE,QANAME,QANCASE,QANDATE,QANDFN
K QANDOB,QANEQ,QANEQ1,QANFIN,QANFLAG,QANHEAD,QANIEN,QANILOC,QANINCD
K QANINIT,QANLBL,QANLREV,QANMN,QANPAT,QANPID,QANSERV,QANSLVL,QANSSN
K QANTYPE,QANWARD,QANWIT,QANXIT,QANXXX,TODAY,X,X1,X2,Y,Z,ZTDESC,ZTRTN
K X3,ZTSAVE,ZTSK
Q
QLOOP ;
F BA="^UTILITY($J,","PAGE","TODAY","QAN*","QAQ*" S ZTSAVE(BA)=""
Q
HDR ;Header generator.
I PAGE,($E(IOST)'="C") W !,"VA Form 10-2633"
S PAGE=PAGE+1 W @IOF,!?69,TODAY,!?69,"Page: ",PAGE,!!
W ?(IOM-$L(QANHEAD)\2),QANHEAD,!
;D EN6^QAQAUTL
W QANEQ1,!,QANEQ1,!
W:$D(QANPID) !,"PATIENT ID: ",QANPID,!
W:QANFLAG&($D(QANLBL)) !?5,QANLBL_"(cont)"
Q
HDH ;Check for end of screen.
I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 QANFIN="^"
Q:QANFIN["^" D HDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANPSDO 4098 printed Apr 09, 2024@21:02:05 Page 2
QANPSDO ;HISC/GJC Pseudo VA 10-2633 ; 10/1/92
+1 ;;2.0;Incident Reporting;**1,31**;08/07/1992
+2 ;
+3 ;CHOOSE PATIENT, THEN THE INCIDENT PUT INTO REPORT OPTION
+4 ;***QANDFN IS FILE 742'S IEN ***:*** QANIEN IS FILE 742.4'S IEN ***
PAT ;
+1 SET QANXIT=0
KILL DIR
SET DIR("A")="Do you wish to generate a blank 10-2633? "
+2 SET DIR(0)="YA"
SET DIR("?")="Enter 'Y' for yes, 'N' for no."
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)!($DATA(DIROUT))
GOTO KILL
+4 SET QANBLNK=+Y
if QANBLNK
GOTO SETUP
+5 KILL DIC
SET DIC="^QA(742,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select Patient: "
+6 SET DIC("S1")="I ""013""[+$P(^QA(742.4,+$P(^QA(742,+Y,0),U,3),0),U,8)"
+7 SET DIC("S2")="&('$D(^QA(742,""BPRS"",-1,+Y)))"
+8 SET DIC("S")=DIC("S1")_DIC("S2")
+9 SET DIC("W")="D DICW^QANUTL1"
SET D="B^BS5"
DO MIX^DIC1
KILL D,DIC
+10 IF +Y=-1
SET QANXIT=1
WRITE !!,*7,"Patient not selected, exiting!!"
GOTO EXIT
PAT1 WRITE !?5,Y(0,0)_" OK"
SET %=1
DO YN^DICN
if %=2
GOTO PAT
+1 if %<0
SET QANXIT=1
if QANXIT
WRITE !!,*7,"Patient not selected, exiting!!"
if QANXIT
GOTO EXIT
+2 IF %=0
WRITE !!,*7,"Enter ""Y""es if the patient choice is correct, ""N""o if the patient choice is ",!,"incorrect.",!
GOTO PAT
+3 SET QANDFN=+Y
SET QANIEN=$PIECE(Y(0),U,3)
SET QANAME=Y(0,0)
+4 IF '$DATA(QANIEN)!('$DATA(QANDFN))
WRITE !!,*7,"Incomplete data, exiting the report."
QUIT
+5 SET QAN742=$GET(^QA(742,QANDFN,0))
SET QAN7424=$GET(^QA(742.4,QANIEN,0))
SET QANPAT=$PIECE(QAN742,U)
if +QANPAT<1
QUIT
SETUP ;"Jump" here to set up vars for blank report, fall through for normal.
+1 SET QANHEAD="PATIENT INCIDENT WORKSHEET"
SET PAGE=0
SET $PIECE(QANEQ,"=",81)=""
SET $PIECE(QANEQ1,"-",81)=""
SET QANFLAG=0
TASK ;Task off to a device.
+1 SET Y=DT
XECUTE ^DD("DD")
SET TODAY=Y
SET QANFIN=""
+2 ;*** Choose device ***
+3 KILL IOP,%ZIS
SET %ZIS("A")="Print on device: "
SET %ZIS="MQ"
WRITE !
DO ^%ZIS
WRITE !!
+4 if POP
GOTO KILL
+5 IF $DATA(IO("Q"))
SET ZTRTN="STRT^QANPSDO"
SET ZTDESC="Generate Patient Incident Worksheet(s)."
DO QLOOP
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request queued!",1:"Request cancelled!"),!
GOTO EXIT
STRT ;
+1 USE IO
DO HDR
if QANBLNK
GOTO BLANK
+2 SET QANAME=$PIECE($PIECE(^DPT(QANPAT,0),U),",",2)_" "_$PIECE($PIECE(^DPT(QANPAT,0),U),",")
SET QANPID=$PIECE(QAN742,U,2)
SET QANSSN=$EXTRACT($PIECE(^DPT(QANPAT,0),U,9),1,3)_"-"_$EXTRACT($PIECE(^DPT(QANPAT,0),U,9),4,5)_"-"_$EXTRACT($PIECE(^DPT(QANPAT,0),U,9),6,9)
SET QANCASE=$PIECE(QAN7424,U)
+3 SET QANDOB=$PIECE(^DPT(QANPAT,0),U,3)
SET X=DT
SET X1=X
SET X2=QANDOB
SET X=""
if +X2>0
DO ^%DTC
SET X=X\365.25
SET QANAGE=X
KILL X,X1,X2,QANDOB
+4 KILL C,Y
SET Y=$PIECE(QAN742,U,4)
SET C=$PIECE(^DD(742,.04,0),U,2)
if Y]""
DO Y^DIQ
SET QANADMT=Y
KILL C,Y
+5 KILL C,Y
SET Y=$PIECE(QAN742,U,6)
SET C=$PIECE(^DD(742,.06,0),U,2)
if Y]""
DO Y^DIQ
SET QANWARD=Y
KILL C,Y
+6 KILL C,Y
SET Y=$PIECE(QAN742,U,8)
SET C=$PIECE(^DD(742,.08,0),U,2)
if Y]""
DO Y^DIQ
SET QANSERV=Y
KILL C,Y
+7 KILL C,Y
SET Y=$PIECE(QAN7424,U,2)
SET C=$PIECE(^DD(742.4,.02,0),U,2)
if Y]""
DO Y^DIQ
SET QANINCD=Y
KILL C,Y
+8 KILL C,Y
SET Y=$PIECE(QAN7424,U,11)
SET C=$PIECE(^DD(742.4,.12,0),U,2)
if Y]""
DO Y^DIQ
SET QANLREV=Y
KILL C,Y
+9 KILL C,Y
SET Y=$PIECE(QAN7424,U,4)
SET C=$PIECE(^DD(742.4,.04,0),U,2)
if Y]""
DO Y^DIQ
SET QANILOC=Y
KILL C,Y
+10 KILL C,Y
SET Y=$PIECE(QAN7424,U,9)
SET C=$PIECE(^DD(742.4,.1,0),U,2)
if Y]""
DO Y^DIQ
SET QANINIT=Y
KILL C,Y
+11 KILL C,Y
SET Y=$PIECE(QAN7424,U,3)
SET C=$PIECE(^DD(742.4,.03,0),U,2)
if Y]""
DO Y^DIQ
SET QANDATE=Y
KILL C,Y
+12 KILL C,Y
SET Y=$PIECE(QAN742,U,10)
SET C=$PIECE(^DD(742,.1,0),U,2)
if Y]""
DO Y^DIQ
SET QANSLVL=Y
KILL C,Y
+13 KILL C,Y
SET Y=$PIECE(QAN7424,U,7)
SET C=$PIECE(^DD(742.4,.08,0),U,2)
if Y]""
DO Y^DIQ
SET QANWIT=Y
KILL C,Y
BLANK ; Do prints
DO ^QANPSD1
+1 IF $EXTRACT(IOST)'="C"
FOR
WRITE !
if $Y>(IOSL-4)
WRITE "VA Form 10-2633"
if $Y>(IOSL-4)
QUIT
EXIT WRITE !
DO ^%ZISC
DO HOME^%ZIS
KILL ;Kill and Quit
+1 KILL %T,%W,%Y,DTOUT,DUOUT,DIROUT,DIRUT,QANBLNK,QANLNCT
+2 KILL %,%ZIS,BA,C,D,DIC,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,PAGE
+3 KILL POP,QAN,QAN742,QAN7424,QANADMT,QANAGE,QANAME,QANCASE,QANDATE,QANDFN
+4 KILL QANDOB,QANEQ,QANEQ1,QANFIN,QANFLAG,QANHEAD,QANIEN,QANILOC,QANINCD
+5 KILL QANINIT,QANLBL,QANLREV,QANMN,QANPAT,QANPID,QANSERV,QANSLVL,QANSSN
+6 KILL QANTYPE,QANWARD,QANWIT,QANXIT,QANXXX,TODAY,X,X1,X2,Y,Z,ZTDESC,ZTRTN
+7 KILL X3,ZTSAVE,ZTSK
+8 QUIT
QLOOP ;
+1 FOR BA="^UTILITY($J,","PAGE","TODAY","QAN*","QAQ*"
SET ZTSAVE(BA)=""
+2 QUIT
HDR ;Header generator.
+1 IF PAGE
IF ($EXTRACT(IOST)'="C")
WRITE !,"VA Form 10-2633"
+2 SET PAGE=PAGE+1
WRITE @IOF,!?69,TODAY,!?69,"Page: ",PAGE,!!
+3 WRITE ?(IOM-$LENGTH(QANHEAD)\2),QANHEAD,!
+4 ;D EN6^QAQAUTL
+5 WRITE QANEQ1,!,QANEQ1,!
+6 if $DATA(QANPID)
WRITE !,"PATIENT ID: ",QANPID,!
+7 if QANFLAG&($DATA(QANLBL))
WRITE !?5,QANLBL_"(cont)"
+8 QUIT
HDH ;Check for end of screen.
+1 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET QANFIN="^"
+2 if QANFIN["^"
QUIT
DO HDR
+3 QUIT
