- NURA7A ;HIRMFO/MD,FT-HOME PHONE NUMBERS FOR ENTIRE STAFF ;8/8/96 13:45
- ;;4.0;NURSING SERVICE;;Apr 25, 1997
- Q:'$D(^DIC(213.9,1,"OFF")) Q:$P(^DIC(213.9,1,"OFF"),"^",1)=1
- W ! S (NURSW1,NUROUT,NURPAGE,NURQUIT)=0
- D EN1^NURSAUTL G QUIT:NUROUT
- I NURMDSW S DIC(0)="AEQZ",NURPLSCR=0 D EN5^NURSAGSP G:$G(NUROUT) QUIT
- I NURMDSW=0,NURPLSW=1 S NURPLSCR=0 D PRD^NURSAGSP K NURPLSCR I $G(NUROUT) G QUIT
- W ! S ZTDESC="Nursing Home Phone Numbers for Entrie Staff",ZTRTN="START^NURA7A" D EN7^NURSUT0 G:POP!($D(ZTSK)) QUIT
- START ;
- K ^TMP($J)
- S X="" F S X=$O(^NURSF(210,"AC",X)) Q:X="" I X'="R" F DA=0:0 S DA=$O(^NURSF(210,"AC",X,DA)) Q:DA'>0 I $G(^NURSF(210,DA,0))'="" S DA(1)=+^NURSF(210,DA,0) D:+DA(1) BLD
- U IO D PRINT
- QUIT ;
- K ^TMP($J) D CLOSE^NURSUT1,^NURAKILL
- Q
- BLD W:$E(IOST)="C"&'($R(10)) "." Q:NURSZAP>7&(NURSZDA'=DA) S N1=$S($P($G(^VA(200,DA(1),0)),U)'="":$P($G(^(0)),"^"),1:" BLANK")
- N X,Y,Z K NUR("DIQ1") S DIC="^NURSF(210,",DR="3;4",DIQ="NUR(""DIQ1"",",DIQ(0)="EN" D EN^DIQ1 K DIC,DIQ,DR
- S NURFAC(2)=$S($G(NUR("DIQ1",210,DA,4,"E"))'="":NUR("DIQ1",210,DA,4,"E"),1:" BLANK")
- S NURPROG(2)=$S($G(NUR("DIQ1",210,DA,3,"E"))'="":NUR("DIQ1",210,DA,3,"E"),1:" BLANK")
- I $G(NURMDSW),'$G(NURFAC),$G(NURFAC(1))'=$G(NURFAC(2)) Q
- I $G(NURPLSW),$G(NURPROG)=0,$G(NURPROG(1))'=$G(NURPROG(2)) Q
- I $G(NURPLSW) S:NURPROG(2)="NURSING" NURPROG(2)=" NURSING"
- S ^TMP($J,NURFAC(2),NURPROG(2),N1,DA)=""
- Q
- ; DETAIL LINE PRINT ROUTINE
- PRINT S NURFAC(2)="" F S NURFAC(2)=$O(^TMP($J,NURFAC(2))) Q:NURFAC(2)="" D P0 Q:NURQUIT
- Q
- P0 S NURPROG(2)="" F S NURPROG(2)=$O(^TMP($J,NURFAC(2),NURPROG(2))) Q:NURPROG(2)="" D:NURSW1 HEADER Q:NURQUIT D P1 Q:NURQUIT
- Q
- P1 S N1="" F S N1=$O(^TMP($J,NURFAC(2),NURPROG(2),N1)) Q:N1="" D P2 Q:NURQUIT
- Q
- P2 F DA=0:0 S DA=$O(^TMP($J,NURFAC(2),NURPROG(2),N1,DA)) Q:DA'>0 D WRITE Q:NURQUIT
- Q
- WRITE I 'NURSW1!($Y>(IOSL-6)) D HEADER Q:NURQUIT
- S NURSW1=1 W ! I $D(^VA(200,$P(^NURSF(210,DA,0),"^"),0)),$P(^(0),"^",1)'="" W $E($P(^(0),"^",1),1,20)
- D EN2^NURSUT0 W ?36,NPSPOS
- F NS2=0:0 S NS2=$O(^NURSF(210,DA,2,NS2)) Q:NS2'>0 W:NS2'=$O(^NURSF(210,DA,2,0)) ! W:$D(^NURSF(210,DA,2,NS2,0)) ?51,$P(^(0),"^",1) S NO=$P(^(0),"^",2) W ?66,$S(NO="S":"SELF",NO="R":"RELATIVE",NO="N":"NEIGHBOR",NO="O":"OTHER",1:"")
- Q
- S NURPAGE=NURPAGE+1 W:$E(IOST)="C"!(NURPAGE>1) @IOF
- I NURMDSW W ?$$CNTR^NURSUT2(NURFAC(2)),$$FACL^NURSUT2(NURFAC(2))
- W !!,"TELEPHONE NUMBERS OF NURSING EMPLOYEES" S X="T" D ^%DT D:+Y D^DIQ W ?44,Y,?59,"PAGE: ",NURPAGE
- W !!,"EMPLOYEE",?36,"SERVICE",?51,"TELEPHONE",?66,"OWNER OF" W !,"NAME",?36,"POSITION",?51,"NUMBER",?66,"PHONE NO." W !,$$REPEAT^XLFSTR("-",80)
- I $G(NURPLSW) N Z S Z=$$PROD^NURSUT2(NURPROG(2)) W !,?$$CNTR^NURSUT2(Z),$G(Z),!,?$$CNTR^NURSUT2(Z),$$REPEAT^XLFSTR("-",$L(Z)+1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURA7A 2862 printed Feb 18, 2025@23:44:51 Page 2
- NURA7A ;HIRMFO/MD,FT-HOME PHONE NUMBERS FOR ENTIRE STAFF ;8/8/96 13:45
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- +2 if '$DATA(^DIC(213.9,1,"OFF"))
- QUIT
- if $PIECE(^DIC(213.9,1,"OFF"),"^",1)=1
- QUIT
- +3 WRITE !
- SET (NURSW1,NUROUT,NURPAGE,NURQUIT)=0
- +4 DO EN1^NURSAUTL
- if NUROUT
- GOTO QUIT
- +5 IF NURMDSW
- SET DIC(0)="AEQZ"
- SET NURPLSCR=0
- DO EN5^NURSAGSP
- if $GET(NUROUT)
- GOTO QUIT
- +6 IF NURMDSW=0
- IF NURPLSW=1
- SET NURPLSCR=0
- DO PRD^NURSAGSP
- KILL NURPLSCR
- IF $GET(NUROUT)
- GOTO QUIT
- +7 WRITE !
- SET ZTDESC="Nursing Home Phone Numbers for Entrie Staff"
- SET ZTRTN="START^NURA7A"
- DO EN7^NURSUT0
- if POP!($DATA(ZTSK))
- GOTO QUIT
- START ;
- +1 KILL ^TMP($JOB)
- +2 SET X=""
- FOR
- SET X=$ORDER(^NURSF(210,"AC",X))
- if X=""
- QUIT
- IF X'="R"
- FOR DA=0:0
- SET DA=$ORDER(^NURSF(210,"AC",X,DA))
- if DA'>0
- QUIT
- IF $GET(^NURSF(210,DA,0))'=""
- SET DA(1)=+^NURSF(210,DA,0)
- if +DA(1)
- DO BLD
- +3 USE IO
- DO PRINT
- QUIT ;
- +1 KILL ^TMP($JOB)
- DO CLOSE^NURSUT1
- DO ^NURAKILL
- +2 QUIT
- BLD if $EXTRACT(IOST)="C"&'($RANDOM(10))
- WRITE "."
- if NURSZAP>7&(NURSZDA'=DA)
- QUIT
- SET N1=$SELECT($PIECE($GET(^VA(200,DA(1),0)),U)'="":$PIECE($GET(^(0)),"^"),1:" BLANK")
- +1 NEW X,Y,Z
- KILL NUR("DIQ1")
- SET DIC="^NURSF(210,"
- SET DR="3;4"
- SET DIQ="NUR(""DIQ1"","
- SET DIQ(0)="EN"
- DO EN^DIQ1
- KILL DIC,DIQ,DR
- +2 SET NURFAC(2)=$SELECT($GET(NUR("DIQ1",210,DA,4,"E"))'="":NUR("DIQ1",210,DA,4,"E"),1:" BLANK")
- +3 SET NURPROG(2)=$SELECT($GET(NUR("DIQ1",210,DA,3,"E"))'="":NUR("DIQ1",210,DA,3,"E"),1:" BLANK")
- +4 IF $GET(NURMDSW)
- IF '$GET(NURFAC)
- IF $GET(NURFAC(1))'=$GET(NURFAC(2))
- QUIT
- +5 IF $GET(NURPLSW)
- IF $GET(NURPROG)=0
- IF $GET(NURPROG(1))'=$GET(NURPROG(2))
- QUIT
- +6 IF $GET(NURPLSW)
- if NURPROG(2)="NURSING"
- SET NURPROG(2)=" NURSING"
- +7 SET ^TMP($JOB,NURFAC(2),NURPROG(2),N1,DA)=""
- +8 QUIT
- +9 ; DETAIL LINE PRINT ROUTINE
- PRINT SET NURFAC(2)=""
- FOR
- SET NURFAC(2)=$ORDER(^TMP($JOB,NURFAC(2)))
- if NURFAC(2)=""
- QUIT
- DO P0
- if NURQUIT
- QUIT
- +1 QUIT
- P0 SET NURPROG(2)=""
- FOR
- SET NURPROG(2)=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(2)))
- if NURPROG(2)=""
- QUIT
- if NURSW1
- DO HEADER
- if NURQUIT
- QUIT
- DO P1
- if NURQUIT
- QUIT
- +1 QUIT
- P1 SET N1=""
- FOR
- SET N1=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(2),N1))
- if N1=""
- QUIT
- DO P2
- if NURQUIT
- QUIT
- +1 QUIT
- P2 FOR DA=0:0
- SET DA=$ORDER(^TMP($JOB,NURFAC(2),NURPROG(2),N1,DA))
- if DA'>0
- QUIT
- DO WRITE
- if NURQUIT
- QUIT
- +1 QUIT
- WRITE IF 'NURSW1!($Y>(IOSL-6))
- DO HEADER
- if NURQUIT
- QUIT
- +1 SET NURSW1=1
- WRITE !
- IF $DATA(^VA(200,$PIECE(^NURSF(210,DA,0),"^"),0))
- IF $PIECE(^(0),"^",1)'=""
- WRITE $EXTRACT($PIECE(^(0),"^",1),1,20)
- +2 DO EN2^NURSUT0
- WRITE ?36,NPSPOS
- +3 FOR NS2=0:0
- SET NS2=$ORDER(^NURSF(210,DA,2,NS2))
- if NS2'>0
- QUIT
- if NS2'=$ORDER(^NURSF(210,DA,2,0))
- WRITE !
- if $DATA(^NURSF(210,DA,2,NS2,0))
- WRITE ?51,$PIECE(^(0),"^",1)
- SET NO=$PIECE(^(0),"^",2)
- WRITE ?66,$SELECT(NO="S":"SELF",NO="R":"RELATIVE",NO="N":"NEIGHBOR",NO="O":"OTHER",1:"")
- +4 QUIT
- IF NURSW1
- 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 NURMDSW
- WRITE ?$$CNTR^NURSUT2(NURFAC(2)),$$FACL^NURSUT2(NURFAC(2))
- +3 WRITE !!,"TELEPHONE NUMBERS OF NURSING EMPLOYEES"
- SET X="T"
- DO ^%DT
- if +Y
- DO D^DIQ
- WRITE ?44,Y,?59,"PAGE: ",NURPAGE
- +4 WRITE !!,"EMPLOYEE",?36,"SERVICE",?51,"TELEPHONE",?66,"OWNER OF"
- WRITE !,"NAME",?36,"POSITION",?51,"NUMBER",?66,"PHONE NO."
- WRITE !,$$REPEAT^XLFSTR("-",80)
- +5 IF $GET(NURPLSW)
- NEW Z
- SET Z=$$PROD^NURSUT2(NURPROG(2))
- WRITE !,?$$CNTR^NURSUT2(Z),$GET(Z),!,?$$CNTR^NURSUT2(Z),$$REPEAT^XLFSTR("-",$LENGTH(Z)+1)
- +6 QUIT
