- RMPRSIT ;PHX/HNC-SET UP SITE PARAMETERS ;8/29/1994
- ;;3.0;PROSTHETICS;**46,90**;Feb 09, 1996
- ;modified to accomodate a NULL chief signature block
- I '$D(RMPRSITE) S X=" ",DIC=669.9,DIC(0)="ZM" D ^DIC S:+Y>0 RMPRSITE=+Y S:+Y'>0 RMPRSITE=$O(^RMPR(669.9,0)) Q:+RMPRSITE'>0 D INF Q
- I '$D(^RMPR(669.9,RMPRSITE)) S RMPRSITE=$O(^RMPR(669.9,0))
- D INF Q
- DIV4 ;SET UP RMPR ARRAY FOR SINGLE AND MULT-DIVISIONAL SITES
- ;RMPR("STA") IS SET TO A VALUE THAT POINTS INTO THE ENTRY IN FILE 669.9
- ;VARIABLES REQUIRED: NOME
- ;Q:$G(RMPRSITE)>0
- S RMPRSITE=0 F RI=1:1 S RMPRSITE=$O(^RMPR(669.9,RMPRSITE)) Q:RMPRSITE'>0
- I RI=2 S RMPRSITE=0,RMPRSITE=$O(^RMPR(669.9,RMPRSITE)) S RMPR("STA")=$P(^RMPR(669.9,RMPRSITE,0),U,2)
- K DIC,Y S X=" ",DIC=669.9,DIC(0)="MZ" D ^DIC I +Y>0 S DIC("B")=Y(0,0)
- I RI>2 K RMPRSITE S DIC="^RMPR(669.9,",DIC(0)="AEQM",DIC("A")="SITE: ",DIC("W")="W ?50,$S($D(^DIC(4,$P(^(0),U,2),99)):$P(^(99),U),1:"""")" D ^DIC Q:+Y<0 S RMPRSITE=+Y
- INF S RMPR("ADD")=$S($D(^RMPR(669.9,RMPRSITE,2)):$P(^RMPR(669.9,RMPRSITE,2),U,2),1:"")
- S RMPR("CITY")=$S($D(^RMPR(669.9,RMPRSITE,2)):$P(^RMPR(669.9,RMPRSITE,2),U,3)_", "_$S(+$P(^(2),U,4)>0:$P(^DIC(5,$P(^(2),U,4),0),U,2),1:""),1:"")
- I $D(^RMPR(669.9,RMPRSITE,2)) I $P(^RMPR(669.9,RMPRSITE,2),U,4)'>0 S RMPR("CITY")=$P(^DIC(4,$P(^RMPR(669.9,RMPRSITE,0),U,2),0),U,1)
- S RMPR("CITY")=RMPR("CITY")_" "_$S($D(^RMPR(669.9,RMPRSITE,2)):$P(^RMPR(669.9,RMPRSITE,2),U,5),1:"")
- ;S RMPR("NAME")=$P(^RMPR(669.9,RMPRSITE,0),U,1) I $D(^RMPR(669.9,RMPRSITE,2)) S RMPR("SIG")=$P(^RMPR(669.9,RMPRSITE,2),U,6),RMPR("SBT")=$P(^(2),U,1)
- S RMPR("NAME")=$P(^RMPR(669.9,RMPRSITE,0),U,1)
- S RMPR("SIG")=$P($G(^RMPR(669.9,RMPRSITE,2)),U,6),RMPR("SBT")=$P($G(^(2)),U,1)
- S RMPR("STA")=$P(^RMPR(669.9,RMPRSITE,0),U,2)
- S RMPR("PHONE")=$P(^RMPR(669.9,RMPRSITE,0),U,4)
- S $P(RMPR("L"),"-",IOM)=""
- K X,Y,I,DIC,RI Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRSIT 1859 printed Feb 19, 2025@00:04:12 Page 2
- RMPRSIT ;PHX/HNC-SET UP SITE PARAMETERS ;8/29/1994
- +1 ;;3.0;PROSTHETICS;**46,90**;Feb 09, 1996
- +2 ;modified to accomodate a NULL chief signature block
- +3 IF '$DATA(RMPRSITE)
- SET X=" "
- SET DIC=669.9
- SET DIC(0)="ZM"
- DO ^DIC
- if +Y>0
- SET RMPRSITE=+Y
- if +Y'>0
- SET RMPRSITE=$ORDER(^RMPR(669.9,0))
- if +RMPRSITE'>0
- QUIT
- DO INF
- QUIT
- +4 IF '$DATA(^RMPR(669.9,RMPRSITE))
- SET RMPRSITE=$ORDER(^RMPR(669.9,0))
- +5 DO INF
- QUIT
- DIV4 ;SET UP RMPR ARRAY FOR SINGLE AND MULT-DIVISIONAL SITES
- +1 ;RMPR("STA") IS SET TO A VALUE THAT POINTS INTO THE ENTRY IN FILE 669.9
- +2 ;VARIABLES REQUIRED: NOME
- +3 ;Q:$G(RMPRSITE)>0
- +4 SET RMPRSITE=0
- FOR RI=1:1
- SET RMPRSITE=$ORDER(^RMPR(669.9,RMPRSITE))
- if RMPRSITE'>0
- QUIT
- +5 IF RI=2
- SET RMPRSITE=0
- SET RMPRSITE=$ORDER(^RMPR(669.9,RMPRSITE))
- SET RMPR("STA")=$PIECE(^RMPR(669.9,RMPRSITE,0),U,2)
- +6 KILL DIC,Y
- SET X=" "
- SET DIC=669.9
- SET DIC(0)="MZ"
- DO ^DIC
- IF +Y>0
- SET DIC("B")=Y(0,0)
- +7 IF RI>2
- KILL RMPRSITE
- SET DIC="^RMPR(669.9,"
- SET DIC(0)="AEQM"
- SET DIC("A")="SITE: "
- SET DIC("W")="W ?50,$S($D(^DIC(4,$P(^(0),U,2),99)):$P(^(99),U),1:"""")"
- DO ^DIC
- if +Y<0
- QUIT
- SET RMPRSITE=+Y
- INF SET RMPR("ADD")=$SELECT($DATA(^RMPR(669.9,RMPRSITE,2)):$PIECE(^RMPR(669.9,RMPRSITE,2),U,2),1:"")
- +1 SET RMPR("CITY")=$SELECT($DATA(^RMPR(669.9,RMPRSITE,2)):$PIECE(^RMPR(669.9,RMPRSITE,2),U,3)_", "_$SELECT(+$PIECE(^(2),U,4)>0:$PIECE(^DIC(5,$PIECE(^(2),U,4),0),U,2),1:""),1:"")
- +2 IF $DATA(^RMPR(669.9,RMPRSITE,2))
- IF $PIECE(^RMPR(669.9,RMPRSITE,2),U,4)'>0
- SET RMPR("CITY")=$PIECE(^DIC(4,$PIECE(^RMPR(669.9,RMPRSITE,0),U,2),0),U,1)
- +3 SET RMPR("CITY")=RMPR("CITY")_" "_$SELECT($DATA(^RMPR(669.9,RMPRSITE,2)):$PIECE(^RMPR(669.9,RMPRSITE,2),U,5),1:"")
- +4 ;S RMPR("NAME")=$P(^RMPR(669.9,RMPRSITE,0),U,1) I $D(^RMPR(669.9,RMPRSITE,2)) S RMPR("SIG")=$P(^RMPR(669.9,RMPRSITE,2),U,6),RMPR("SBT")=$P(^(2),U,1)
- +5 SET RMPR("NAME")=$PIECE(^RMPR(669.9,RMPRSITE,0),U,1)
- +6 SET RMPR("SIG")=$PIECE($GET(^RMPR(669.9,RMPRSITE,2)),U,6)
- SET RMPR("SBT")=$PIECE($GET(^(2)),U,1)
- +7 SET RMPR("STA")=$PIECE(^RMPR(669.9,RMPRSITE,0),U,2)
- +8 SET RMPR("PHONE")=$PIECE(^RMPR(669.9,RMPRSITE,0),U,4)
- +9 SET $PIECE(RMPR("L"),"-",IOM)=""
- +10 KILL X,Y,I,DIC,RI
- QUIT