- PSOCPBAK ;BIR/EJW-Tally unbilled NON-SERVICE CONNECTED copays ;03/28/03
- ;;7.0;OUTPATIENT PHARMACY;**137,268,480**;DEC 1997;Build 35
- ;External reference to ^XUSEC supported by DBIA 10076
- ;External reference to IBARX supported by DBIA 125
- S ZTDTH=""
- I $D(ZTQUEUED) S ZTDTH=$H
- L +^XTMP("PSOCPBAK"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T D Q
- . I ZTDTH="" D BMES^XPDUTL("Tally job is already running. Halting...")
- L -^XTMP("PSOCPBAK")
- I ZTDTH="" D
- .D BMES^XPDUTL("Tally unbilled, released NON-SERVICE CONNECTED prescription fills.")
- .D BMES^XPDUTL("If no start date/time is entered when prompted, the background job will be ")
- .D MES^XPDUTL("queued to run NOW.")
- .D GETDATE
- .D BMES^XPDUTL("Queuing background job to tally unbilled NON-SERVICE CONNECTED fills...")
- S ZTRTN="EN^PSOCPBAK",ZTIO="",ZTDESC="Background job to tally NON-SERVICE CONNECTED unbilled copays" D ^%ZTLOAD K ZTDTH,ZTRTN,ZTIO,ZTDESC
- W:$D(ZTSK)&('$D(ZTQUEUED)) !!,"Task Queued !",!
- Q
- EN ;
- L +^XTMP("PSOCPBAK"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T S:$D(ZTQUEUED) ZTREQ="@" Q
- N PSODT,RXP,PSOTEXT,YY,PSOCNT,PSOSTART,PSOEND,PSOVETS
- S PSOCNT=0
- D NOW^%DTC S (Y,PSOS1)=% D DD^%DT S PSOSTART=Y
- S PSOSTRT2=$$FMTE^XLFDT(%,"1PS")
- I '$G(DT) S DT=$$DT^XLFDT
- I '$D(^XTMP("PSOCPBAK")) S X1=DT,X2=+90 D C^%DTC S ^XTMP("PSOCPBAK",0)=$G(X)_"^"_DT
- S PSODT=3020203.235959 ; START WITH DATE $7 COPAY WENT INTO EFFECT
- F S PSODT=$O(^PSRX("AL",PSODT)) Q:'PSODT S RXP="" F S RXP=$O(^PSRX("AL",PSODT,RXP)) Q:'RXP D
- .S PSODFN=$P($G(^PSRX(RXP,0)),"^",2) Q:PSODFN="" I '$D(^DPT(PSODFN,0)) Q
- .I $G(^XTMP("PSOCPBAK",$J,PSODFN)) Q ; EXEMPT OR SC QUESTION APPLIES-- NOTHING TO REPROCESS FOR THIS PATIENT
- .S BADDT=$G(^XTMP("PSOCPBAK",$J,PSODFN,RXP))
- .I 'BADDT D CHKLOG
- .I BADDT,BADDT'>$P(PSODT,".") D
- ..I '$D(^XTMP("PSOCPBAK",$J,PSODFN)) D XTYPE S ^XTMP("PSOCPBAK",$J,PSODFN)=$S(PSOSCMX=1:"",1:1) I PSOSCMX'=1 Q ; QUIT IF SC QUESTION APPLIES -- NOTHING TO REPROCESS
- ..S YY="" F S YY=$O(^PSRX("AL",PSODT,RXP,YY)) Q:YY="" D
- ...S PSOREL=$S(YY=0:$P(^PSRX(RXP,2),"^",13),1:$P($G(^PSRX(RXP,1,YY,0)),"^",18)) I 'PSOREL Q ; RELEASED DATE WON'T BE PRESENT IF RETURNED TO STOCK
- ...I 'YY I $P($G(^PSRX(RXP,"IB")),"^",2)'="" Q ; ALREADY BILLED
- ...I 'YY I $P($G(^PSRX(RXP,"IB")),"^",4)'="" Q ; ALREADY BILLED (POTENTIAL BILL - EXCEEDED ANNUAL CAP)
- ...I YY,$P($G(^PSRX(RXP,1,YY,"IB")),"^",1)'="" Q ; REFILL ALREADY BILLED
- ...I YY,$P($G(^PSRX(RXP,1,YY,"IB")),"^",2)'="" Q ; REFILL ALREADY BILLED (POTENTIAL BILL - EXCEEDED ANNUAL CAP)
- ...S PSOXIN=$$RXST^IBARXEU(PSODFN,$P(PSOREL,".")) I $P($G(PSOXIN),"^")=1 Q ; INCOME EXEMPT ON RELEASE DATE
- ...I '$D(^XTMP("PSOCPBAK",$J,PSODFN,RXP)) S ^XTMP("PSOCPBAK",$J,PSODFN,RXP)=BADDT
- ...S ^XTMP("PSOCPBAK",$J,PSODFN,RXP,YY)=$P(PSOREL,".") ; SAVE TO PROCESS IN "BILL" SECTION
- D TALLY^PSOCPBA2
- D TOTAL
- D MAIL
- D MAIL2
- L -^XTMP("PSOCPBAK")
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- ;
- MAIL ;
- D NOW^%DTC S Y=% D DD^%DT S PSOEND=Y
- I $G(DUZ) S XMY(DUZ)=""
- S XMDUZ="Outpatient Pharmacy",XMSUB="Outpatient Pharmacy Copay Tally"
- F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)=""
- I $O(XMY(""))="" Q ; no recipients for mail message
- S PSOTEXT(1)="The Rx copay tally job for the Outpatient Pharmacy patch (PSO*7*137)"
- S PSOTEXT(2)="started "_PSOSTART_" and completed "_PSOEND_"."
- I PSOCNT>0 S PSOTEXT(3)="Released non-service connected prescriptions have now been reprocessed."
- I PSOCNT>0 S PSOTEXT(4)="There were "_PSOCNT_" fills successfully tallied for "_$G(PSOVETS)_" veterans." D
- .S PSOTEXT(5)=" "
- .S PSOTEXT(6)="Fills eligible for back-billing by year:"
- .S PSOTEXT(7)="2002 30-DAY EQUIVALENT FILLS: "_PSOCNT("YR2002",1)
- .S PSOTEXT(8)="2002 60-DAY EQUIVALENT FILLS: "_PSOCNT("YR2002",2)
- .S PSOTEXT(9)="2002 90-DAY EQUIVALENT FILLS: "_PSOCNT("YR2002",3)
- .S PSOTEXT(10)=""
- .S PSOTEXT(11)="2003 30-DAY EQUIVALENT FILLS: "_PSOCNT("YR2003",1)
- .S PSOTEXT(12)="2003 60-DAY EQUIVALENT FILLS: "_PSOCNT("YR2003",2)
- .S PSOTEXT(13)="2003 90-DAY EQUIVALENT FILLS: "_PSOCNT("YR2003",3)
- I PSOCNT=0 S PSOTEXT(3)="No released unbilled copay fills were found."
- S XMTEXT="PSOTEXT(" N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
- Q
- ;
- MAIL2 ;
- N I,COUNTS
- D NOW^%DTC S PSOTIME=$$FMDIFF^XLFDT(%,PSOS1,2)
- S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^")
- K PSOTEXT
- S COUNTS=""
- F J="YR2002","YR2003" F I=1:1:3 S COUNTS=COUNTS_"^"_PSOCNT(J,I)
- K XMY(DUZ)
- S XMY("WHITE.ELAINE@DOMAIN.EXT")=""
- S XMY("CARROLL.DAN@DOMAIN.EXT")=""
- S XMDUZ="PSO*7*137 TALLY",XMSUB=$G(PSOINST)_" - COUNTS"
- S PSOTEXT(1)=PSOSTRT2_"^"_PSOTIME_"^"_$G(PSOVETS)_"^"_PSOCNT_COUNTS
- S XMTEXT="PSOTEXT(" N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
- Q
- ;
- CHKLOG ;
- S BADDT=""
- S PSOSQ=0 F S PSOSQ=$O(^PSRX(RXP,"COPAY",PSOSQ)) Q:'PSOSQ S PSOLOG=$G(^PSRX(RXP,"COPAY",PSOSQ,0)) I PSOLOG["Service Connected" S BADDT=$P(PSOLOG,".") Q
- Q
- ;
- GETDATE ; GET DATE/TIME OF WHEN BACKGROUND JOB SHOULD BE RUN
- S ZTDTH=""
- S NOW=0
- D NOW^%DTC S (Y,TODAY)=% D DD^%DT
- D BMES^XPDUTL("At the following prompt, enter a starting date@time")
- D MES^XPDUTL("or enter NOW to queue the job immediately.")
- D BMES^XPDUTL("If this prompting is during patch installation, you will not see what you type.")
- W ! K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Queue copay tally Job to run Date@Time: "
- D ^%DT K %DT I $D(DTOUT)!(Y<0) W "Task will be queued to run NOW" S ZTDTH=$H,NOW=1
- I 'NOW,Y>0 D
- .S SAVEY=Y
- .D DD^%DT
- .S X=Y
- .S Y=SAVEY
- ASK D BMES^XPDUTL("Task will be queued to run "_$S(NOW:"NOW",1:X)_". Is that correct? :")
- R XX:300 S:'$T XX="Y" I XX'="Y",XX'="y",XX'="N",XX'="n" W " Enter Y or N" G ASK
- I XX'="Y",XX'="y" G GETDATE
- I Y>0,ZTDTH="" S ZTDTH=Y
- I ZTDTH="" S ZTDTH=$H
- Q
- ;
- XTYPE ;
- N Y,I,J,X,SAVY,DFN
- S DFN=PSODFN D DEM^VADPT I +$G(VADM(6)) S PSOSCMX="" Q ; DECEASED
- S (X,PSOSCMX,SAVY)=""
- S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q
- I 'X Q
- S X=X_"^"_PSODFN D XTYPE^IBARX
- I $G(Y)'=1 Q
- S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I
- I PSOSCMX="",SAVY=0 S PSOEXMPT=1 Q ; INCOME EXEMPT OR SERVICE-CONNECTED
- I PSOSCMX=2 Q ; NEED TO ASK SC QUESTION
- Q
- ;
- TOTAL ;
- N COUNT,COUNTED
- I '$D(PSOVETS) S PSOVETS=0
- N I,J
- F I=1:1:3 S (PSOCNT("YR2002",I),PSOCNT("YR2003",I))=0
- S PSODFN=0 F S PSODFN=$O(^XTMP("PSOCPBAK",$J,PSODFN)) Q:'PSODFN D
- .S COUNTED=0
- .F J="YR2002","YR2003" F I=1:1:3 S COUNT=$G(^XTMP("PSOCPBAK",$J,PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT
- F I=1:1:3 S PSOCNT=PSOCNT+PSOCNT("YR2002",I)+PSOCNT("YR2003",I)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPBAK 6738 printed Jan 18, 2025@03:26:53 Page 2
- PSOCPBAK ;BIR/EJW-Tally unbilled NON-SERVICE CONNECTED copays ;03/28/03
- +1 ;;7.0;OUTPATIENT PHARMACY;**137,268,480**;DEC 1997;Build 35
- +2 ;External reference to ^XUSEC supported by DBIA 10076
- +3 ;External reference to IBARX supported by DBIA 125
- +4 SET ZTDTH=""
- +5 IF $DATA(ZTQUEUED)
- SET ZTDTH=$HOROLOG
- +6 LOCK +^XTMP("PSOCPBAK"):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
- IF '$TEST
- Begin DoDot:1
- +7 IF ZTDTH=""
- DO BMES^XPDUTL("Tally job is already running. Halting...")
- End DoDot:1
- QUIT
- +8 LOCK -^XTMP("PSOCPBAK")
- +9 IF ZTDTH=""
- Begin DoDot:1
- +10 DO BMES^XPDUTL("Tally unbilled, released NON-SERVICE CONNECTED prescription fills.")
- +11 DO BMES^XPDUTL("If no start date/time is entered when prompted, the background job will be ")
- +12 DO MES^XPDUTL("queued to run NOW.")
- +13 DO GETDATE
- +14 DO BMES^XPDUTL("Queuing background job to tally unbilled NON-SERVICE CONNECTED fills...")
- End DoDot:1
- +15 SET ZTRTN="EN^PSOCPBAK"
- SET ZTIO=""
- SET ZTDESC="Background job to tally NON-SERVICE CONNECTED unbilled copays"
- DO ^%ZTLOAD
- KILL ZTDTH,ZTRTN,ZTIO,ZTDESC
- +16 if $DATA(ZTSK)&('$DATA(ZTQUEUED))
- WRITE !!,"Task Queued !",!
- +17 QUIT
- EN ;
- +1 LOCK +^XTMP("PSOCPBAK"):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
- IF '$TEST
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +2 NEW PSODT,RXP,PSOTEXT,YY,PSOCNT,PSOSTART,PSOEND,PSOVETS
- +3 SET PSOCNT=0
- +4 DO NOW^%DTC
- SET (Y,PSOS1)=%
- DO DD^%DT
- SET PSOSTART=Y
- +5 SET PSOSTRT2=$$FMTE^XLFDT(%,"1PS")
- +6 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +7 IF '$DATA(^XTMP("PSOCPBAK"))
- SET X1=DT
- SET X2=+90
- DO C^%DTC
- SET ^XTMP("PSOCPBAK",0)=$GET(X)_"^"_DT
- +8 ; START WITH DATE $7 COPAY WENT INTO EFFECT
- SET PSODT=3020203.235959
- +9 FOR
- SET PSODT=$ORDER(^PSRX("AL",PSODT))
- if 'PSODT
- QUIT
- SET RXP=""
- FOR
- SET RXP=$ORDER(^PSRX("AL",PSODT,RXP))
- if 'RXP
- QUIT
- Begin DoDot:1
- +10 SET PSODFN=$PIECE($GET(^PSRX(RXP,0)),"^",2)
- if PSODFN=""
- QUIT
- IF '$DATA(^DPT(PSODFN,0))
- QUIT
- +11 ; EXEMPT OR SC QUESTION APPLIES-- NOTHING TO REPROCESS FOR THIS PATIENT
- IF $GET(^XTMP("PSOCPBAK",$JOB,PSODFN))
- QUIT
- +12 SET BADDT=$GET(^XTMP("PSOCPBAK",$JOB,PSODFN,RXP))
- +13 IF 'BADDT
- DO CHKLOG
- +14 IF BADDT
- IF BADDT'>$PIECE(PSODT,".")
- Begin DoDot:2
- +15 ; QUIT IF SC QUESTION APPLIES -- NOTHING TO REPROCESS
- IF '$DATA(^XTMP("PSOCPBAK",$JOB,PSODFN))
- DO XTYPE
- SET ^XTMP("PSOCPBAK",$JOB,PSODFN)=$SELECT(PSOSCMX=1:"",1:1)
- IF PSOSCMX'=1
- QUIT
- +16 SET YY=""
- FOR
- SET YY=$ORDER(^PSRX("AL",PSODT,RXP,YY))
- if YY=""
- QUIT
- Begin DoDot:3
- +17 ; RELEASED DATE WON'T BE PRESENT IF RETURNED TO STOCK
- SET PSOREL=$SELECT(YY=0:$PIECE(^PSRX(RXP,2),"^",13),1:$PIECE($GET(^PSRX(RXP,1,YY,0)),"^",18))
- IF 'PSOREL
- QUIT
- +18 ; ALREADY BILLED
- IF 'YY
- IF $PIECE($GET(^PSRX(RXP,"IB")),"^",2)'=""
- QUIT
- +19 ; ALREADY BILLED (POTENTIAL BILL - EXCEEDED ANNUAL CAP)
- IF 'YY
- IF $PIECE($GET(^PSRX(RXP,"IB")),"^",4)'=""
- QUIT
- +20 ; REFILL ALREADY BILLED
- IF YY
- IF $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",1)'=""
- QUIT
- +21 ; REFILL ALREADY BILLED (POTENTIAL BILL - EXCEEDED ANNUAL CAP)
- IF YY
- IF $PIECE($GET(^PSRX(RXP,1,YY,"IB")),"^",2)'=""
- QUIT
- +22 ; INCOME EXEMPT ON RELEASE DATE
- SET PSOXIN=$$RXST^IBARXEU(PSODFN,$PIECE(PSOREL,"."))
- IF $PIECE($GET(PSOXIN),"^")=1
- QUIT
- +23 IF '$DATA(^XTMP("PSOCPBAK",$JOB,PSODFN,RXP))
- SET ^XTMP("PSOCPBAK",$JOB,PSODFN,RXP)=BADDT
- +24 ; SAVE TO PROCESS IN "BILL" SECTION
- SET ^XTMP("PSOCPBAK",$JOB,PSODFN,RXP,YY)=$PIECE(PSOREL,".")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +25 DO TALLY^PSOCPBA2
- +26 DO TOTAL
- +27 DO MAIL
- +28 DO MAIL2
- +29 LOCK -^XTMP("PSOCPBAK")
- +30 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +31 QUIT
- +32 ;
- MAIL ;
- +1 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET PSOEND=Y
- +2 IF $GET(DUZ)
- SET XMY(DUZ)=""
- +3 SET XMDUZ="Outpatient Pharmacy"
- SET XMSUB="Outpatient Pharmacy Copay Tally"
- +4 FOR PSOCXPDA=0:0
- SET PSOCXPDA=$ORDER(^XUSEC("PSO COPAY",PSOCXPDA))
- if 'PSOCXPDA
- QUIT
- SET XMY(PSOCXPDA)=""
- +5 ; no recipients for mail message
- IF $ORDER(XMY(""))=""
- QUIT
- +6 SET PSOTEXT(1)="The Rx copay tally job for the Outpatient Pharmacy patch (PSO*7*137)"
- +7 SET PSOTEXT(2)="started "_PSOSTART_" and completed "_PSOEND_"."
- +8 IF PSOCNT>0
- SET PSOTEXT(3)="Released non-service connected prescriptions have now been reprocessed."
- +9 IF PSOCNT>0
- SET PSOTEXT(4)="There were "_PSOCNT_" fills successfully tallied for "_$GET(PSOVETS)_" veterans."
- Begin DoDot:1
- +10 SET PSOTEXT(5)=" "
- +11 SET PSOTEXT(6)="Fills eligible for back-billing by year:"
- +12 SET PSOTEXT(7)="2002 30-DAY EQUIVALENT FILLS: "_PSOCNT("YR2002",1)
- +13 SET PSOTEXT(8)="2002 60-DAY EQUIVALENT FILLS: "_PSOCNT("YR2002",2)
- +14 SET PSOTEXT(9)="2002 90-DAY EQUIVALENT FILLS: "_PSOCNT("YR2002",3)
- +15 SET PSOTEXT(10)=""
- +16 SET PSOTEXT(11)="2003 30-DAY EQUIVALENT FILLS: "_PSOCNT("YR2003",1)
- +17 SET PSOTEXT(12)="2003 60-DAY EQUIVALENT FILLS: "_PSOCNT("YR2003",2)
- +18 SET PSOTEXT(13)="2003 90-DAY EQUIVALENT FILLS: "_PSOCNT("YR2003",3)
- End DoDot:1
- +19 IF PSOCNT=0
- SET PSOTEXT(3)="No released unbilled copay fills were found."
- +20 SET XMTEXT="PSOTEXT("
- NEW DIFROM
- DO ^XMD
- KILL XMDUZ,XMTEXT,XMSUB
- +21 QUIT
- +22 ;
- MAIL2 ;
- +1 NEW I,COUNTS
- +2 DO NOW^%DTC
- SET PSOTIME=$$FMDIFF^XLFDT(%,PSOS1,2)
- +3 SET PSOINST=$PIECE($GET(^DIC(4,+$PIECE($GET(^XMB(1,1,"XUS")),"^",17),99)),"^")
- +4 KILL PSOTEXT
- +5 SET COUNTS=""
- +6 FOR J="YR2002","YR2003"
- FOR I=1:1:3
- SET COUNTS=COUNTS_"^"_PSOCNT(J,I)
- +7 KILL XMY(DUZ)
- +8 SET XMY("WHITE.ELAINE@DOMAIN.EXT")=""
- +9 SET XMY("CARROLL.DAN@DOMAIN.EXT")=""
- +10 SET XMDUZ="PSO*7*137 TALLY"
- SET XMSUB=$GET(PSOINST)_" - COUNTS"
- +11 SET PSOTEXT(1)=PSOSTRT2_"^"_PSOTIME_"^"_$GET(PSOVETS)_"^"_PSOCNT_COUNTS
- +12 SET XMTEXT="PSOTEXT("
- NEW DIFROM
- DO ^XMD
- KILL XMDUZ,XMTEXT,XMSUB
- +13 QUIT
- +14 ;
- CHKLOG ;
- +1 SET BADDT=""
- +2 SET PSOSQ=0
- FOR
- SET PSOSQ=$ORDER(^PSRX(RXP,"COPAY",PSOSQ))
- if 'PSOSQ
- QUIT
- SET PSOLOG=$GET(^PSRX(RXP,"COPAY",PSOSQ,0))
- IF PSOLOG["Service Connected"
- SET BADDT=$PIECE(PSOLOG,".")
- QUIT
- +3 QUIT
- +4 ;
- GETDATE ; GET DATE/TIME OF WHEN BACKGROUND JOB SHOULD BE RUN
- +1 SET ZTDTH=""
- +2 SET NOW=0
- +3 DO NOW^%DTC
- SET (Y,TODAY)=%
- DO DD^%DT
- +4 DO BMES^XPDUTL("At the following prompt, enter a starting date@time")
- +5 DO MES^XPDUTL("or enter NOW to queue the job immediately.")
- +6 DO BMES^XPDUTL("If this prompting is during patch installation, you will not see what you type.")
- +7 WRITE !
- KILL %DT
- DO NOW^%DTC
- SET %DT="RAEX"
- SET %DT(0)=%
- SET %DT("A")="Queue copay tally Job to run Date@Time: "
- +8 DO ^%DT
- KILL %DT
- IF $DATA(DTOUT)!(Y<0)
- WRITE "Task will be queued to run NOW"
- SET ZTDTH=$HOROLOG
- SET NOW=1
- +9 IF 'NOW
- IF Y>0
- Begin DoDot:1
- +10 SET SAVEY=Y
- +11 DO DD^%DT
- +12 SET X=Y
- +13 SET Y=SAVEY
- End DoDot:1
- ASK DO BMES^XPDUTL("Task will be queued to run "_$SELECT(NOW:"NOW",1:X)_". Is that correct? :")
- +1 READ XX:300
- if '$TEST
- SET XX="Y"
- IF XX'="Y"
- IF XX'="y"
- IF XX'="N"
- IF XX'="n"
- WRITE " Enter Y or N"
- GOTO ASK
- +2 IF XX'="Y"
- IF XX'="y"
- GOTO GETDATE
- +3 IF Y>0
- IF ZTDTH=""
- SET ZTDTH=Y
- +4 IF ZTDTH=""
- SET ZTDTH=$HOROLOG
- +5 QUIT
- +6 ;
- XTYPE ;
- +1 NEW Y,I,J,X,SAVY,DFN
- +2 ; DECEASED
- SET DFN=PSODFN
- DO DEM^VADPT
- IF +$GET(VADM(6))
- SET PSOSCMX=""
- QUIT
- +3 SET (X,PSOSCMX,SAVY)=""
- +4 SET J=0
- FOR
- SET J=$ORDER(^PS(59,J))
- if 'J
- QUIT
- IF +$GET(^(J,"IB"))
- SET X=+^("IB")
- QUIT
- +5 IF 'X
- QUIT
- +6 SET X=X_"^"_PSODFN
- DO XTYPE^IBARX
- +7 IF $GET(Y)'=1
- QUIT
- +8 SET J=""
- FOR
- SET J=$ORDER(Y(J))
- if 'J
- QUIT
- SET I=""
- FOR
- SET SAVY=I
- SET I=$ORDER(Y(J,I))
- if I=""
- QUIT
- if I>0
- SET PSOSCMX=I
- +9 ; INCOME EXEMPT OR SERVICE-CONNECTED
- IF PSOSCMX=""
- IF SAVY=0
- SET PSOEXMPT=1
- QUIT
- +10 ; NEED TO ASK SC QUESTION
- IF PSOSCMX=2
- QUIT
- +11 QUIT
- +12 ;
- TOTAL ;
- +1 NEW COUNT,COUNTED
- +2 IF '$DATA(PSOVETS)
- SET PSOVETS=0
- +3 NEW I,J
- +4 FOR I=1:1:3
- SET (PSOCNT("YR2002",I),PSOCNT("YR2003",I))=0
- +5 SET PSODFN=0
- FOR
- SET PSODFN=$ORDER(^XTMP("PSOCPBAK",$JOB,PSODFN))
- if 'PSODFN
- QUIT
- Begin DoDot:1
- +6 SET COUNTED=0
- +7 FOR J="YR2002","YR2003"
- FOR I=1:1:3
- SET COUNT=$GET(^XTMP("PSOCPBAK",$JOB,PSODFN,J,I))
- IF COUNT>0
- if '$GET(COUNTED)
- SET COUNTED=1
- SET PSOVETS=PSOVETS+1
- SET PSOCNT(J,I)=PSOCNT(J,I)+COUNT
- End DoDot:1
- +8 FOR I=1:1:3
- SET PSOCNT=PSOCNT+PSOCNT("YR2002",I)+PSOCNT("YR2003",I)
- +9 QUIT
- +10 ;