- SDWLRPT2 ;;IOFO BAY PINES/TEH - WAIT LIST REPORT FORMAT 2 (PCMM);06/12/2002 ; 29 Aug 2002 2:54 PM
- ;;5.3;scheduling;**263**;AUG 13 1993
- ;
- ;
- ;******************************************************************
- ; CHANGE LOG
- ;
- ; DATE PATCH DESCRIPTION
- ; ---- ----- -----------
- ;
- ;
- ;
- ;
- EN ;
- D INIT
- D SORT
- I $$S^%ZTLOAD G END
- D PRINT
- I $$S^%ZTLOAD G END
- K ^TMP("SDWLRPT2",$J)
- Q
- INIT ;Initialize variables
- ;
- I $D(CT1) S SDWLCT1=CT1
- I $D(CT2) S SDWLCT2=CT2
- I $D(DATE) S SDWLDATE=DATE
- I $D(FORM) S SDWLFORM=FORM
- I $D(INS) S SDWLINS=INS
- I $D(OPEN) S SDWLOPEN=OPEN
- S SDWLPG=0
- I $D(ZTSAVE) D
- .F SDWLI="CT1","CT2","DATE","FORM","INS","OPEN","PRI" S SDWL="SDWL"_SDWLI,@SDWL=$G(ZTSAVE(SDWLI))
- I SDWLINS="ALL" S SDWLIN("ALL")=""
- S SDWLTXP=$P(SDWLCT1,U,3)
- I SDWLINS'="ALL" F SDWLI=1:1 S SDWLIN=$P($P(SDWLINS,";",SDWLI),U,1) Q:SDWLIN="" S SDWLIN(SDWLIN)="",^TMP("SDWLRPT2",$J,$P(^DIC(4,SDWLIN,0),U,1))=0
- I SDWLCT2'="ALL" F SDWLI=1:1 S SDWLCT=$P($P(SDWLCT2,";",SDWLI),U,1) Q:SDWLCT="" S SDWLCT2(SDWLCT)=""
- I '$D(SDWLDATE) S SDWLBD=0,SDWLED=9999999 G INIT1
- I SDWLDATE="ALL" S SDWLBD=0,SDWLED=9999999 G INIT1
- S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2)
- INIT1 D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=$P(Y,":",1,2)
- Q
- SORT ;Sort Records
- K ^TMP("SDWLRPT2",$J) S SDWLCNT=0
- S SDWLDA=0 F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D
- .S SDWLX=$G(^SDWL(409.3,SDWLDA,0)),SDWLERR=0,SDWLDFN=+SDWLX
- .;-Check for Institution Sort
- .I SDWLINS'="ALL" D
- ..I '$D(SDWLIN(+$P(SDWLX,U,3))) S SDWLERR=1 Q
- .S SDWLTY1=$P(SDWLX,U,5)
- .S SDWLTYP=$P(SDWLCT1,U,1)
- .S SDWLTY2=$S(SDWLTYP="T":1,1:2) I SDWLTY1'=SDWLTY2 S SDWLERR=10
- .S SDWLTYPE=$S(SDWLTYP="T":$P(SDWLX,U,6),1:$P(SDWLX,U,7)) I SDWLTYPE=""!('SDWLTYPE) S SDWLERR=7 Q
- .S SDWLFLD=$S(SDWLTYP="T":5,1:6)
- .I SDWLCT2'="ALL" D
- ..I '$D(SDWLCT2(SDWLTYPE)) S SDWLERR=3
- .I SDWLTYP="" S SDWLERR=4 Q
- .I SDWLOPEN'["C",$P(SDWLX,U,17)'[SDWLOPEN S SDWLERR=6 Q
- .Q:SDWLERR D
- ..S SDWLSCC=2,DFN=SDWLDFN D ELIG^VADPT I $D(VAEL(3)) S SDWLSCN=$P(VAEL(3),U,2) I SDWLSCN>49 S SDWLSCC=1
- ..S SDWLF=$P(SDWLCT1,U,2),SDWLIENS=+$P(SDWLX,U,3)_",",SDWLIX=$$GET1^DIQ(4,SDWLIENS,".01")
- ..S SDWLSIEN=SDWLTYPE_",",Y=$$GET1^DIQ(SDWLF,SDWLSIEN,".01")
- ..S ^TMP("SDWLRPT2",$J,SDWLIX,Y,SDWLSCC,SDWLDA)=""
- ..S SDWLCNT=SDWLCNT+1,^TMP("SDWLRPT2",$J,$P(^DIC(4,$P(SDWLX,U,3),0),U,1))=SDWLCNT
- Q
- PRINT ;Print Report
- S SDWLCNT=0 D HD I '$D(^TMP("SDWLRPT2",$J)) W !!,?80-$L("*** No Patient Records to Report ***")\2,"*** No Patient Records to Report ***" Q
- S SDWLA="" F S SDWLA=$O(^TMP("SDWLRPT2",$J,SDWLA)) G END:$$S^%ZTLOAD Q:SDWLA="" D Q:$D(DUOUT)
- .D LINE W !!,"Institution: " W SDWLA I '$G(^TMP("SDWLRPT2",$J,SDWLA)) W !!,"*** No Patient Records to Report ***"
- .S SDWLB="" F S SDWLB=$O(^TMP("SDWLRPT2",$J,SDWLA,SDWLB)) Q:SDWLB="" D Q:$D(DUOUT)
- ..W !!,"Team/Position: " W SDWLB,!
- ..S SDWLC="" F S SDWLC=$O(^TMP("SDWLRPT2",$J,SDWLA,SDWLB,SDWLC)) Q:SDWLC="" D Q:$D(DUOUT)
- ...S SDWLD="" F S SDWLD=$O(^TMP("SDWLRPT2",$J,SDWLA,SDWLB,SDWLC,SDWLD)) Q:SDWLD="" D Q:$D(DUOUT)
- ....S SDWLDFN=$P($G(^SDWL(409.3,SDWLD,0)),U,1),DFN=SDWLDFN D DEM^VADPT,ELIG^VADPT,ADD^VADPT
- ....S SDWLNAM=VADM(1),SDWLELIG=VAEL(1) I SDWLELIG="" S SDWLELIG=0
- ....S SDWLODT=$P($G(^SDWL(409.3,SDWLD,0)),U,2) S Y=SDWLODT D DD^%DT S SDWLODT=Y
- ....S SDWLDEAD=1
- ....S SDWLSSN=VA("BID"),SDWLAPTD=$P(^SDWL(409.3,SDWLD,0),U,16),SDWLCOM=$P(^SDWL(409.3,SDWLD,0),U,18)
- ....S SDWLRBY=$P(^SDWL(409.3,SDWLD,0),U,12),SDWLRPV=$P(^SDWL(409.3,SDWLD,0),U,13)
- ....S SDWLPH=$G(VAPA(8)) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
- ....W !!,SDWLNAM,?40,SDWLSSN,?50,"Date Entered: ",SDWLODT
- ....W !,"Primary Eligibility: ",$P(SDWLELIG,U,2)
- ....W !,"Comments: ",SDWLCOM,!
- ....I SDWLRBY W !,"Requested by: ",$$EXTERNAL^DILFD(409.3,11,,SDWLRBY)
- ....I SDWLRPV W ?35,"Requesting Provider: " S X=$$EXTERNAL^DILFD(409.3,12,,SDWLRPV) W X
- ....W !,"Telephone (Home): ",$P(SDWLPH,U,1) I $P(SDWLPH,U,2) W !,?10,"(Work): ",$P(SDWLPH,U,2)
- ....I $D(^SDWL(409.3,SDWLD,"DIS")) D
- .....S SDWLDISX=$G(^SDWL(409.3,SDWLD,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2)
- .....S SDWLDDT=$P(^SDWL(409.3,SDWLD,"DIS"),U,1),SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3)
- .....I $D(SDWLDISX) W !,"Disposition: ",$P(SDWLDISX,U,3)," (",SDWLDIDT,")" K SDWLDISX,SDWLDIS,SDWLDDUZ,SDWLDIDT
- ....W !,"*****"
- ....I $D(SDWLSPT),$Y>(IOSL-3) S DIR(0)="E" D ^DIR I X["^" S DUOUT=1
- ....I '$D(SDWLSPT),$Y>(IOSL-5) D HD
- W !!,"** End of Report **"
- Q
- LINE ;Draw Line
- W !,"_______________________________________________________________________________"
- Q
- HD ;Header
- W:$D(IOF) @IOF W !,SDWLDTP,?80-$L("PCMM Team/Position Wait List Report")\2,"PCMM Team/Position Wait List Report"
- S SDWLPG=SDWLPG+1 W ?72,"Page: ",SDWLPG
- W !!,?30,"Institution: " I SDWLINS="ALL" D
- .W ?45,SDWLINS
- F I=1:1 S X=$P(SDWLINS,";",I) Q:X="" S SDWLIENS=X_"," W:I>1 ! W ?45,$$GET1^DIQ(4,SDWLIENS,".01")
- S X=$P(SDWLCT2,U,2)
- W !?26,"Report Category: ",$S($P(SDWLCT1,U,1)="T":"TEAM",1:"POSITION") I X="ALL" W " ALL"
- I X'="ALL" D
- .F I=1:1 S X=$P($P(SDWLCT2,";",I),"^",2) Q:X="" W !,?45,X
- S X=$G(SDWLOPEN) W !,?35,"Status: ",$S(SDWLOPEN="O":"Open",1:"All")
- S X=$G(SDWLFORM) W !,?28,"Output Format: ",$S(SDWLFORM="S":"Summary",1:"Detailed")
- Q
- END D EN^SDWLKIL K VADM,VAPA,SDWLIENS,SDWLIX,CT1,CT2,DATE,I,INS,OPEN,FORM,SDWLSIEN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLRPT2 5590 printed Apr 23, 2025@19:17:58 Page 2
- SDWLRPT2 ;;IOFO BAY PINES/TEH - WAIT LIST REPORT FORMAT 2 (PCMM);06/12/2002 ; 29 Aug 2002 2:54 PM
- +1 ;;5.3;scheduling;**263**;AUG 13 1993
- +2 ;
- +3 ;
- +4 ;******************************************************************
- +5 ; CHANGE LOG
- +6 ;
- +7 ; DATE PATCH DESCRIPTION
- +8 ; ---- ----- -----------
- +9 ;
- +10 ;
- +11 ;
- +12 ;
- EN ;
- +1 DO INIT
- +2 DO SORT
- +3 IF $$S^%ZTLOAD
- GOTO END
- +4 DO PRINT
- +5 IF $$S^%ZTLOAD
- GOTO END
- +6 KILL ^TMP("SDWLRPT2",$JOB)
- +7 QUIT
- INIT ;Initialize variables
- +1 ;
- +2 IF $DATA(CT1)
- SET SDWLCT1=CT1
- +3 IF $DATA(CT2)
- SET SDWLCT2=CT2
- +4 IF $DATA(DATE)
- SET SDWLDATE=DATE
- +5 IF $DATA(FORM)
- SET SDWLFORM=FORM
- +6 IF $DATA(INS)
- SET SDWLINS=INS
- +7 IF $DATA(OPEN)
- SET SDWLOPEN=OPEN
- +8 SET SDWLPG=0
- +9 IF $DATA(ZTSAVE)
- Begin DoDot:1
- +10 FOR SDWLI="CT1","CT2","DATE","FORM","INS","OPEN","PRI"
- SET SDWL="SDWL"_SDWLI
- SET @SDWL=$GET(ZTSAVE(SDWLI))
- End DoDot:1
- +11 IF SDWLINS="ALL"
- SET SDWLIN("ALL")=""
- +12 SET SDWLTXP=$PIECE(SDWLCT1,U,3)
- +13 IF SDWLINS'="ALL"
- FOR SDWLI=1:1
- SET SDWLIN=$PIECE($PIECE(SDWLINS,";",SDWLI),U,1)
- if SDWLIN=""
- QUIT
- SET SDWLIN(SDWLIN)=""
- SET ^TMP("SDWLRPT2",$JOB,$PIECE(^DIC(4,SDWLIN,0),U,1))=0
- +14 IF SDWLCT2'="ALL"
- FOR SDWLI=1:1
- SET SDWLCT=$PIECE($PIECE(SDWLCT2,";",SDWLI),U,1)
- if SDWLCT=""
- QUIT
- SET SDWLCT2(SDWLCT)=""
- +15 IF '$DATA(SDWLDATE)
- SET SDWLBD=0
- SET SDWLED=9999999
- GOTO INIT1
- +16 IF SDWLDATE="ALL"
- SET SDWLBD=0
- SET SDWLED=9999999
- GOTO INIT1
- +17 SET SDWLBD=$PIECE(SDWLDATE,U,1)
- SET SDWLED=$PIECE(SDWLDATE,U,2)
- INIT1 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET SDWLDTP=$PIECE(Y,":",1,2)
- +1 QUIT
- SORT ;Sort Records
- +1 KILL ^TMP("SDWLRPT2",$JOB)
- SET SDWLCNT=0
- +2 SET SDWLDA=0
- FOR
- SET SDWLDA=$ORDER(^SDWL(409.3,SDWLDA))
- if SDWLDA<1
- QUIT
- Begin DoDot:1
- +3 SET SDWLX=$GET(^SDWL(409.3,SDWLDA,0))
- SET SDWLERR=0
- SET SDWLDFN=+SDWLX
- +4 ;-Check for Institution Sort
- +5 IF SDWLINS'="ALL"
- Begin DoDot:2
- +6 IF '$DATA(SDWLIN(+$PIECE(SDWLX,U,3)))
- SET SDWLERR=1
- QUIT
- End DoDot:2
- +7 SET SDWLTY1=$PIECE(SDWLX,U,5)
- +8 SET SDWLTYP=$PIECE(SDWLCT1,U,1)
- +9 SET SDWLTY2=$SELECT(SDWLTYP="T":1,1:2)
- IF SDWLTY1'=SDWLTY2
- SET SDWLERR=10
- +10 SET SDWLTYPE=$SELECT(SDWLTYP="T":$PIECE(SDWLX,U,6),1:$PIECE(SDWLX,U,7))
- IF SDWLTYPE=""!('SDWLTYPE)
- SET SDWLERR=7
- QUIT
- +11 SET SDWLFLD=$SELECT(SDWLTYP="T":5,1:6)
- +12 IF SDWLCT2'="ALL"
- Begin DoDot:2
- +13 IF '$DATA(SDWLCT2(SDWLTYPE))
- SET SDWLERR=3
- End DoDot:2
- +14 IF SDWLTYP=""
- SET SDWLERR=4
- QUIT
- +15 IF SDWLOPEN'["C"
- IF $PIECE(SDWLX,U,17)'[SDWLOPEN
- SET SDWLERR=6
- QUIT
- +16 if SDWLERR
- QUIT
- Begin DoDot:2
- +17 SET SDWLSCC=2
- SET DFN=SDWLDFN
- DO ELIG^VADPT
- IF $DATA(VAEL(3))
- SET SDWLSCN=$PIECE(VAEL(3),U,2)
- IF SDWLSCN>49
- SET SDWLSCC=1
- +18 SET SDWLF=$PIECE(SDWLCT1,U,2)
- SET SDWLIENS=+$PIECE(SDWLX,U,3)_","
- SET SDWLIX=$$GET1^DIQ(4,SDWLIENS,".01")
- +19 SET SDWLSIEN=SDWLTYPE_","
- SET Y=$$GET1^DIQ(SDWLF,SDWLSIEN,".01")
- +20 SET ^TMP("SDWLRPT2",$JOB,SDWLIX,Y,SDWLSCC,SDWLDA)=""
- +21 SET SDWLCNT=SDWLCNT+1
- SET ^TMP("SDWLRPT2",$JOB,$PIECE(^DIC(4,$PIECE(SDWLX,U,3),0),U,1))=SDWLCNT
- End DoDot:2
- End DoDot:1
- +22 QUIT
- PRINT ;Print Report
- +1 SET SDWLCNT=0
- DO HD
- IF '$DATA(^TMP("SDWLRPT2",$JOB))
- WRITE !!,?80-$LENGTH("*** No Patient Records to Report ***")\2,"*** No Patient Records to Report ***"
- QUIT
- +2 SET SDWLA=""
- FOR
- SET SDWLA=$ORDER(^TMP("SDWLRPT2",$JOB,SDWLA))
- if $$S^%ZTLOAD
- GOTO END
- if SDWLA=""
- QUIT
- Begin DoDot:1
- +3 DO LINE
- WRITE !!,"Institution: "
- WRITE SDWLA
- IF '$GET(^TMP("SDWLRPT2",$JOB,SDWLA))
- WRITE !!,"*** No Patient Records to Report ***"
- +4 SET SDWLB=""
- FOR
- SET SDWLB=$ORDER(^TMP("SDWLRPT2",$JOB,SDWLA,SDWLB))
- if SDWLB=""
- QUIT
- Begin DoDot:2
- +5 WRITE !!,"Team/Position: "
- WRITE SDWLB,!
- +6 SET SDWLC=""
- FOR
- SET SDWLC=$ORDER(^TMP("SDWLRPT2",$JOB,SDWLA,SDWLB,SDWLC))
- if SDWLC=""
- QUIT
- Begin DoDot:3
- +7 SET SDWLD=""
- FOR
- SET SDWLD=$ORDER(^TMP("SDWLRPT2",$JOB,SDWLA,SDWLB,SDWLC,SDWLD))
- if SDWLD=""
- QUIT
- Begin DoDot:4
- +8 SET SDWLDFN=$PIECE($GET(^SDWL(409.3,SDWLD,0)),U,1)
- SET DFN=SDWLDFN
- DO DEM^VADPT
- DO ELIG^VADPT
- DO ADD^VADPT
- +9 SET SDWLNAM=VADM(1)
- SET SDWLELIG=VAEL(1)
- IF SDWLELIG=""
- SET SDWLELIG=0
- +10 SET SDWLODT=$PIECE($GET(^SDWL(409.3,SDWLD,0)),U,2)
- SET Y=SDWLODT
- DO DD^%DT
- SET SDWLODT=Y
- +11 SET SDWLDEAD=1
- +12 SET SDWLSSN=VA("BID")
- SET SDWLAPTD=$PIECE(^SDWL(409.3,SDWLD,0),U,16)
- SET SDWLCOM=$PIECE(^SDWL(409.3,SDWLD,0),U,18)
- +13 SET SDWLRBY=$PIECE(^SDWL(409.3,SDWLD,0),U,12)
- SET SDWLRPV=$PIECE(^SDWL(409.3,SDWLD,0),U,13)
- +14 SET SDWLPH=$GET(VAPA(8))
- IF SDWLAPTD'=""
- SET Y=SDWLAPTD
- DO DD^%DT
- SET SDWLAPTD=Y
- +15 WRITE !!,SDWLNAM,?40,SDWLSSN,?50,"Date Entered: ",SDWLODT
- +16 WRITE !,"Primary Eligibility: ",$PIECE(SDWLELIG,U,2)
- +17 WRITE !,"Comments: ",SDWLCOM,!
- +18 IF SDWLRBY
- WRITE !,"Requested by: ",$$EXTERNAL^DILFD(409.3,11,,SDWLRBY)
- +19 IF SDWLRPV
- WRITE ?35,"Requesting Provider: "
- SET X=$$EXTERNAL^DILFD(409.3,12,,SDWLRPV)
- WRITE X
- +20 WRITE !,"Telephone (Home): ",$PIECE(SDWLPH,U,1)
- IF $PIECE(SDWLPH,U,2)
- WRITE !,?10,"(Work): ",$PIECE(SDWLPH,U,2)
- +21 IF $DATA(^SDWL(409.3,SDWLD,"DIS"))
- Begin DoDot:5
- +22 SET SDWLDISX=$GET(^SDWL(409.3,SDWLD,"DIS"))
- SET SDWLDIS=$PIECE(SDWLDISX,U,3)
- SET SDWLDDUZ=$PIECE(SDWLDISX,U,2)
- +23 SET SDWLDDT=$PIECE(^SDWL(409.3,SDWLD,"DIS"),U,1)
- SET SDWLDIDT=$EXTRACT(SDWLDDT,4,5)_"/"_$EXTRACT(SDWLDDT,6,7)_"/"_$EXTRACT(SDWLDDT,2,3)
- +24 IF $DATA(SDWLDISX)
- WRITE !,"Disposition: ",$PIECE(SDWLDISX,U,3)," (",SDWLDIDT,")"
- KILL SDWLDISX,SDWLDIS,SDWLDDUZ,SDWLDIDT
- End DoDot:5
- +25 WRITE !,"*****"
- +26 IF $DATA(SDWLSPT)
- IF $Y>(IOSL-3)
- SET DIR(0)="E"
- DO ^DIR
- IF X["^"
- SET DUOUT=1
- +27 IF '$DATA(SDWLSPT)
- IF $Y>(IOSL-5)
- DO HD
- End DoDot:4
- if $DATA(DUOUT)
- QUIT
- End DoDot:3
- if $DATA(DUOUT)
- QUIT
- End DoDot:2
- if $DATA(DUOUT)
- QUIT
- End DoDot:1
- if $DATA(DUOUT)
- QUIT
- +28 WRITE !!,"** End of Report **"
- +29 QUIT
- LINE ;Draw Line
- +1 WRITE !,"_______________________________________________________________________________"
- +2 QUIT
- HD ;Header
- +1 if $DATA(IOF)
- WRITE @IOF
- WRITE !,SDWLDTP,?80-$LENGTH("PCMM Team/Position Wait List Report")\2,"PCMM Team/Position Wait List Report"
- +2 SET SDWLPG=SDWLPG+1
- WRITE ?72,"Page: ",SDWLPG
- +3 WRITE !!,?30,"Institution: "
- IF SDWLINS="ALL"
- Begin DoDot:1
- +4 WRITE ?45,SDWLINS
- End DoDot:1
- +5 FOR I=1:1
- SET X=$PIECE(SDWLINS,";",I)
- if X=""
- QUIT
- SET SDWLIENS=X_","
- if I>1
- WRITE !
- WRITE ?45,$$GET1^DIQ(4,SDWLIENS,".01")
- +6 SET X=$PIECE(SDWLCT2,U,2)
- +7 WRITE !?26,"Report Category: ",$SELECT($PIECE(SDWLCT1,U,1)="T":"TEAM",1:"POSITION")
- IF X="ALL"
- WRITE " ALL"
- +8 IF X'="ALL"
- Begin DoDot:1
- +9 FOR I=1:1
- SET X=$PIECE($PIECE(SDWLCT2,";",I),"^",2)
- if X=""
- QUIT
- WRITE !,?45,X
- End DoDot:1
- +10 SET X=$GET(SDWLOPEN)
- WRITE !,?35,"Status: ",$SELECT(SDWLOPEN="O":"Open",1:"All")
- +11 SET X=$GET(SDWLFORM)
- WRITE !,?28,"Output Format: ",$SELECT(SDWLFORM="S":"Summary",1:"Detailed")
- +12 QUIT
- END DO EN^SDWLKIL
- KILL VADM,VAPA,SDWLIENS,SDWLIX,CT1,CT2,DATE,I,INS,OPEN,FORM,SDWLSIEN
- +1 QUIT
