- NURA6G ;HIRMFO/MD,RM,FT-LICENSE PROFILE BY SERVICE CATEGORY ;8/23/96 09:34
- ;;4.0;NURSING SERVICE;;Apr 25, 1997
- S X=$G(^DIC(213.9,1,"OFF")) Q:X=""!(X=1)
- S (NURPAGE,NURSW1,NURPLSW,NURMDSW,NURQUIT,NURQUEUE,NUROUT)=0,NRNLP=1
- D EN1^NURSAUTL G QUIT:NUROUT
- D EN9^NURSAGSP
- I NURMDSW S DIC(0)="AEMQZ",NURPLSCR=0 D EN5^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
- I NURMDSW=0,NURPLSW=1 S NURPLSCR=0 D PRD^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
- D EN3^NURSAGSP G:NUROUT QUIT
- D EN7^NURSAGP0 G QUIT:NUROUT
- W ! D EN10^NURSAGSP G QUIT:NUROUT
- W ! S ZTDESC="License Profile by Service Category",ZTRTN="START^NURA6G" D EN7^NURSUT0 G:POP!($D(ZTSK)) QUIT
- START ;
- K ^TMP($J) U IO
- D SORT G:NUROUT QUIT D NPRINT
- QUIT K ^TMP($J) D CLOSE^NURSUT1,^NURAKILL
- Q
- NPRINT S NURFAC(2)="" F S NURFAC(2)=$O(^TMP($J,"L",NURFAC(2))) Q:NURFAC(2)="" D NM Q:NURQUIT
- Q
- NM S NURPROG(4)="" F S NURPROG(4)=$O(^TMP($J,"L",NURFAC(2),NURPROG(4))) Q:NURPROG(4)=""!NURQUIT D NHDR Q:NURQUIT D NN Q:NURQUIT
- Q
- NN S NURCAT="" F S NURCAT=$O(^TMP($J,"L",NURFAC(2),NURPROG(4),NURCAT)) Q:NURCAT="" D BRK,NO Q:NURQUIT
- Q
- NO S NLDT="" F S NLDT=$O(^TMP($J,"L",NURFAC(2),NURPROG(4),NURCAT,NLDT)) Q:NLDT="" D NP Q:NURQUIT
- Q
- NP S N1="" F S N1=$O(^TMP($J,"L",NURFAC(2),NURPROG(4),NURCAT,NLDT,N1)) Q:N1="" S NURSORT=$G(^(N1)) I NURSORT S D0=$E(NLDT,8),NLDTPR=$E(NLDT,1,7),DA=$O(^TMP($J,"L1",NURSORT,"")) D NPPRINT Q:NURQUIT
- Q
- NPPRINT I ($Y>(IOSL-6)) D NHDR Q:NURQUIT
- W !
- S:'NURSW1 NURSW1=1
- W:N1'=" BLANK" ?2,$E(N1,1,20)
- I $D(^VA(200,+^NURSF(210,DA,0),1)),$P(^(1),"^",9)'="" S NURSSN=$P(^(1),"^",9) W ?28,$E(NURSSN,1,3),"-",$E(NURSSN,4,5),"-",$E(NURSSN,6,9)
- S Y=NLDTPR D:+Y D^DIQ W:Y'=" BLANK" ?46,Y
- I D0'="",$D(^NURSF(210,+DA,4,D0,0)),$P(^(0),"^",1)'="",$D(^DIC(5,$P(^NURSF(210,DA,4,D0,0),"^",1),0)),$P(^(0),"^",2)'="" W ?60,$P(^(0),"^",2)
- I D0'="",$D(^NURSF(210,DA,4,D0,0)),$P(^(0),"^",2)'="" W ?68,$P(^(0),"^",2)
- Q
- NHDR I 'NURQUEUE,NURSW1,$E(IOST)="C" D ENDPG^NURSUT1 S:NUROUT NURQUIT=+NUROUT Q:NURQUIT
- S NURPAGE=NURPAGE+1 W:$E(IOST)="C"!(NURPAGE>1) @IOF
- I $G(NURMDSW) W !,?$$CNTR^NURSUT2(NURFAC(2)),$S(NURFAC(2)=" BLANK":"NO FACILITY",1:NURFAC(2)),!
- W !,"LICENSE PROFILE" S X="T" D ^%DT D:+Y D^DIQ W ?56,Y,?72,"PAGE: ",NURPAGE
- W !!,?46,"EXPIRATION",?60,"STATE",?68,"PROFESSIONAL"
- W !,?46,"DATE OF",?60,"ISS.",?68,"LICENSE"
- W !,?2,"NAME",?28,"SSN",?46,"LICENSE",?60,"LIC.",?68,"NUMBER"
- W !,$$REPEAT^XLFSTR("-",80)
- D:$G(NURPLSW) BRK1 D BRK
- Q
- SORT W ! S NRPT=8 D EN1^NURAAGS0
- S X=$O(^TMP($J,"")) I X="" S NURPROG(4)=$S($G(NURPROG)=0:NURPROG(1),1:""),NURFAC(2)=$S($G(NURFAC)=0:NURFAC(1),1:"") D NHDR W !,"THERE IS NO DATA FOR THIS REPORT" S NUROUT=1
- Q
- BRK Q:$G(NURCAT)="" W !,?10,"SERVICE CATEGORY: " W:NURCAT'=" BLANK" $$CAT^NURSUT2(NURCAT)
- Q
- BRK1 I $G(NURPROG(4))'="" W !?$$CNTR^NURSUT2(NURPROG(4)),$S(NURPROG(4)=" NURSING":$E(NURPROG(4),2,99),$G(NURPROG(4))=" BLANK":"NO PRODUCT LINE",1:$G(NURPROG(4))) W !?$$CNTR^NURSUT2(NURPROG(4)),$$REPEAT^XLFSTR("-",$L(NURPROG(4))+1),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURA6G 3019 printed Mar 13, 2025@21:23:22 Page 2
- NURA6G ;HIRMFO/MD,RM,FT-LICENSE PROFILE BY SERVICE CATEGORY ;8/23/96 09:34
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- +2 SET X=$GET(^DIC(213.9,1,"OFF"))
- if X=""!(X=1)
- QUIT
- +3 SET (NURPAGE,NURSW1,NURPLSW,NURMDSW,NURQUIT,NURQUEUE,NUROUT)=0
- SET NRNLP=1
- +4 DO EN1^NURSAUTL
- if NUROUT
- GOTO QUIT
- +5 DO EN9^NURSAGSP
- +6 IF NURMDSW
- SET DIC(0)="AEMQZ"
- SET NURPLSCR=0
- DO EN5^NURSAGSP
- KILL NURPLSCR
- IF $GET(NUROUT)
- GOTO QUIT
- +7 IF NURMDSW=0
- IF NURPLSW=1
- SET NURPLSCR=0
- DO PRD^NURSAGSP
- KILL NURPLSCR
- IF $GET(NUROUT)
- GOTO QUIT
- +8 DO EN3^NURSAGSP
- if NUROUT
- GOTO QUIT
- +9 DO EN7^NURSAGP0
- if NUROUT
- GOTO QUIT
- +10 WRITE !
- DO EN10^NURSAGSP
- if NUROUT
- GOTO QUIT
- +11 WRITE !
- SET ZTDESC="License Profile by Service Category"
- SET ZTRTN="START^NURA6G"
- DO EN7^NURSUT0
- if POP!($DATA(ZTSK))
- GOTO QUIT
- START ;
- +1 KILL ^TMP($JOB)
- USE IO
- +2 DO SORT
- if NUROUT
- GOTO QUIT
- DO NPRINT
- QUIT KILL ^TMP($JOB)
- DO CLOSE^NURSUT1
- DO ^NURAKILL
- +1 QUIT
- NPRINT SET NURFAC(2)=""
- FOR
- SET NURFAC(2)=$ORDER(^TMP($JOB,"L",NURFAC(2)))
- if NURFAC(2)=""
- QUIT
- DO NM
- if NURQUIT
- QUIT
- +1 QUIT
- NM SET NURPROG(4)=""
- FOR
- SET NURPROG(4)=$ORDER(^TMP($JOB,"L",NURFAC(2),NURPROG(4)))
- if NURPROG(4)=""!NURQUIT
- QUIT
- DO NHDR
- if NURQUIT
- QUIT
- DO NN
- if NURQUIT
- QUIT
- +1 QUIT
- NN SET NURCAT=""
- FOR
- SET NURCAT=$ORDER(^TMP($JOB,"L",NURFAC(2),NURPROG(4),NURCAT))
- if NURCAT=""
- QUIT
- DO BRK
- DO NO
- if NURQUIT
- QUIT
- +1 QUIT
- NO SET NLDT=""
- FOR
- SET NLDT=$ORDER(^TMP($JOB,"L",NURFAC(2),NURPROG(4),NURCAT,NLDT))
- if NLDT=""
- QUIT
- DO NP
- if NURQUIT
- QUIT
- +1 QUIT
- NP SET N1=""
- FOR
- SET N1=$ORDER(^TMP($JOB,"L",NURFAC(2),NURPROG(4),NURCAT,NLDT,N1))
- if N1=""
- QUIT
- SET NURSORT=$GET(^(N1))
- IF NURSORT
- SET D0=$EXTRACT(NLDT,8)
- SET NLDTPR=$EXTRACT(NLDT,1,7)
- SET DA=$ORDER(^TMP($JOB,"L1",NURSORT,""))
- DO NPPRINT
- if NURQUIT
- QUIT
- +1 QUIT
- NPPRINT IF ($Y>(IOSL-6))
- DO NHDR
- if NURQUIT
- QUIT
- +1 WRITE !
- +2 if 'NURSW1
- SET NURSW1=1
- +3 if N1'=" BLANK"
- WRITE ?2,$EXTRACT(N1,1,20)
- +4 IF $DATA(^VA(200,+^NURSF(210,DA,0),1))
- IF $PIECE(^(1),"^",9)'=""
- SET NURSSN=$PIECE(^(1),"^",9)
- WRITE ?28,$EXTRACT(NURSSN,1,3),"-",$EXTRACT(NURSSN,4,5),"-",$EXTRACT(NURSSN,6,9)
- +5 SET Y=NLDTPR
- if +Y
- DO D^DIQ
- if Y'=" BLANK"
- WRITE ?46,Y
- +6 IF D0'=""
- IF $DATA(^NURSF(210,+DA,4,D0,0))
- IF $PIECE(^(0),"^",1)'=""
- IF $DATA(^DIC(5,$PIECE(^NURSF(210,DA,4,D0,0),"^",1),0))
- IF $PIECE(^(0),"^",2)'=""
- WRITE ?60,$PIECE(^(0),"^",2)
- +7 IF D0'=""
- IF $DATA(^NURSF(210,DA,4,D0,0))
- IF $PIECE(^(0),"^",2)'=""
- WRITE ?68,$PIECE(^(0),"^",2)
- +8 QUIT
- NHDR IF 'NURQUEUE
- IF NURSW1
- IF $EXTRACT(IOST)="C"
- DO ENDPG^NURSUT1
- if NUROUT
- SET NURQUIT=+NUROUT
- if NURQUIT
- QUIT
- +1 SET NURPAGE=NURPAGE+1
- if $EXTRACT(IOST)="C"!(NURPAGE>1)
- WRITE @IOF
- +2 IF $GET(NURMDSW)
- WRITE !,?$$CNTR^NURSUT2(NURFAC(2)),$SELECT(NURFAC(2)=" BLANK":"NO FACILITY",1:NURFAC(2)),!
- +3 WRITE !,"LICENSE PROFILE"
- SET X="T"
- DO ^%DT
- if +Y
- DO D^DIQ
- WRITE ?56,Y,?72,"PAGE: ",NURPAGE
- +4 WRITE !!,?46,"EXPIRATION",?60,"STATE",?68,"PROFESSIONAL"
- +5 WRITE !,?46,"DATE OF",?60,"ISS.",?68,"LICENSE"
- +6 WRITE !,?2,"NAME",?28,"SSN",?46,"LICENSE",?60,"LIC.",?68,"NUMBER"
- +7 WRITE !,$$REPEAT^XLFSTR("-",80)
- +8 if $GET(NURPLSW)
- DO BRK1
- DO BRK
- +9 QUIT
- SORT WRITE !
- SET NRPT=8
- DO EN1^NURAAGS0
- +1 SET X=$ORDER(^TMP($JOB,""))
- IF X=""
- SET NURPROG(4)=$SELECT($GET(NURPROG)=0:NURPROG(1),1:"")
- SET NURFAC(2)=$SELECT($GET(NURFAC)=0:NURFAC(1),1:"")
- DO NHDR
- WRITE !,"THERE IS NO DATA FOR THIS REPORT"
- SET NUROUT=1
- +2 QUIT
- BRK if $GET(NURCAT)=""
- QUIT
- WRITE !,?10,"SERVICE CATEGORY: "
- if NURCAT'=" BLANK"
- WRITE $$CAT^NURSUT2(NURCAT)
- +1 QUIT
- BRK1 IF $GET(NURPROG(4))'=""
- WRITE !?$$CNTR^NURSUT2(NURPROG(4)),$SELECT(NURPROG(4)=" NURSING":$EXTRACT(NURPROG(4),2,99),$GET(NURPROG(4))=" BLANK":"NO PRODUCT LINE",1:$GET(NURPROG(4)))
- WRITE !?$$CNTR^NURSUT2(NURPROG(4)),$$REPEAT^XLFSTR("-",$LENGTH(NURPROG(4))+1),!
- +1 QUIT
