- PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;01/11/2022
- ;;2.0;CLINICAL REMINDERS;**6,45,65**;Feb 04, 2005;Build 438
- ;
- ; API ICR
- ;$$GET^XPAR 2263
- ;SHOWALL^YTQPXRM5 5056
- ;SAVECR^YTQPXRM4 4463
- ;NEW^WVRPCNO 4104
- ;
- ACTIVE(ORY,ORREM) ;Check if active dialog exist for reminders
- ;
- ; input parameter ORREM is array of reminder ien [.01#811.9]
- N DDIS,DIEN,OCNT,RIEN,RSTA
- S OCNT=0,RIEN=0
- ;Get reminder ien from array
- F S RIEN=$O(ORREM(RIEN)) Q:'RIEN D
- .;Dialog ien for reminder
- .S DIEN=$P($G(^PXD(811.9,RIEN,51)),U),RSTA=0
- .;Dialog status
- .I DIEN S DDIS=$P($G(^PXRMD(801.41,DIEN,0)),U,3)
- .;If dialog and dialog not disabled
- .I DIEN,+DDIS=0 S RSTA=1
- .;Return reminder and if active dialog exists
- .S OCNT=OCNT+1,ORY(OCNT)=RIEN_U_RSTA
- Q
- ;
- ;
- DIALOG(ORY,ORREM,DFN,VISITID) ;Load reminder dialog associated with the reminder
- ;
- ; input parameter ORREM - reminder ien [.01,#811.9]
- ;
- S RIEN=ORREM
- N DATA,DIEN
- S DIEN=$G(^PXD(811.9,ORREM,51))
- ;
- ;Quit if no dialog for this reminder
- I 'DIEN S ORY(1)="-1^no dialog for this reminder" Q
- ;
- ;Check if a reminder dialog and enabled
- S DATA=$G(^PXRMD(801.41,DIEN,0))
- ;
- I $P(DATA,U,4)'="R" S ORY(1)="-1^reminder dialog invalid" Q
- ;
- I $P(DATA,U,3) S ORY(1)="-1^reminder dialog disabled" Q
- ;
- ;Load dialog lines into local array
- S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17)
- D LOAD^PXRMDLL(DIEN,$G(DFN),VISITID)
- Q
- ;
- HDR(ORY,ORLOC) ;Progress Note Header by location/service/user
- N ORSRV,PASS
- ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
- S ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
- S PASS=DUZ_";VA(200,"
- I +$G(ORLOC) S PASS=PASS_"^LOC.`"_ORLOC
- I ORSRV>0 S PASS=PASS_"^SRV.`"_+$G(ORSRV)
- S ORY=$$GET^XPAR(PASS_"^DIV^SYS^PKG","PXRM PROGRESS NOTE HEADERS",1,"Q")
- Q
- ;
- PROMPT(ORY,ORDLG,ORDCUR,ORFTYP,ORIEN,NDATA) ;Load additional prompts for a dialog element
- ;
- ; input parameters
- ;
- ; ORDLG - dialog element ien [.01,#801.41]
- ; ORDCUR - 0 = current, 1 = Historical for taxonomies only
- ; ORFTYP - finding type (CPT/POV) for taxonomies only
- ; ORIEN - dialog ien [.01,#801.41]
- ;
- ; These fields can be found in the output array of DIALOG^PXRMRPCC
- ;
- D LOAD^PXRMDLLA(ORDLG,ORDCUR,$G(ORFTYP),$G(ORIEN),$G(NDATA))
- Q
- ;
- RES(ORY,ORREM) ; Reminder Resources/Inquiry
- ;
- ; input parameter ORREM - reminder ien [.01,#811.9]
- ;
- D REMVAR^PXRMINQ(.ORY,ORREM)
- Q
- ;
- MH(ORY,OTEST) ; Mental Health dialog
- ;
- ; Input mental health instrument NAME
- ;
- K ^TMP($J,"YSQU")
- N ARRAY,CNT,CNT1,FNODE,FSUB,IC,NODE,OCNT,SUB,YS
- S YS("CODE")=OTEST D SHOWALL^YTQPXRM5(.ARRAY,.YS)
- S OCNT=0,CNT=0
- S SUB="ARRAY",OCNT=0
- F S SUB=$Q(@SUB) Q:SUB="" D
- .S FSUB=$P($P(SUB,"(",2),")"),FNODE=""
- .F IC=1:1 S NODE=$P(FSUB,",",IC) Q:NODE="" D
- ..I $E(NODE)="""" S NODE=$P(NODE,"""",2)
- ..S $P(FNODE,";",IC)=NODE
- .Q:FNODE=""
- .S OCNT=OCNT+1,ORY(OCNT)=FNODE_U_@SUB
- Q
- ;
- MHR(ORY,RESULT,ORES) ; Mental Health score and P/N text
- ;
- ; Input MH result IEN and mental health instrument response
- ;
- D START^PXRMDLR(.ORY,RESULT,.ORES)
- ;
- Q
- ;
- MHS(ORY,YS) ; Mental Health save response
- ;
- ; Input mental health instrument response
- N ANS,ARRAY,X
- S ANS=$G(YS("R1")) K YS("R1")
- S YS("ADATE")=YS("ADATE")_"."_$P($$NOW^XLFDT,".",2)
- F X=1:1:$L(ANS) I $E(ANS,X)'="X" S YS(X)=X_U_$E(ANS,X)
- D SAVECR^YTQPXRM4(.ARRAY,.YS)
- Q
- ;
- MST(ORY,DFN,DGMSTDT,DGMSTSC,DGMSTPR,FTYP,FIEN,RESULT) ; File MST status
- ;This is obsolete and can be removed when the GUI is changed not
- ;to use it.
- Q
- ;
- PROMPTVL(ORY,VALUE,DIEN,OVALUE,PAT) ; Calculate prompt value
- N ACT,DONE,FUNC,NODE,CNT,FUNC,INPUTS,LINK,NUM,RESULT,RTN,SUB,TEMP,VAL
- S CNT=0,DONE=0 F S CNT=$O(^PXRMD(801.41,DIEN,10,CNT)) Q:CNT'>0!(DONE=1) D
- .S LINK=$P($G(^PXRMD(801.41,DIEN,10,CNT,"LINK")),U) Q:LINK'>0
- .S NODE=^PXRMD(801.48,LINK,0)
- .S FUNC=$P($G(NODE),U,4) I FUNC'>0 Q
- .S ACT=$P(NODE,U,5) I ACT="" Q
- .;build additional inputs
- .S NUM=0 F S NUM=$O(^PXRMD(801.48,LINK,2,NUM)) Q:NUM'>0 D
- ..S NODE=$G(^PXRMD(801.48,LINK,2,NUM,0)),SUB=$P(NODE,U),VAL=$P(NODE,U,2) Q:SUB="" Q:VAL=""
- ..S INPUTS(SUB)=VAL
- .;AGP do we need to still check item and prompt value??
- .;S RESULT="",FUNC=$P($G(NODE),U,4) I FUNC>0 D REMFUN(.RESULT,FUNC,PAT,VALUE,OVALUE)
- .S RESULT="",RTN=$P($G(^PXRMD(801.47,FUNC,0)),U,2,3) Q:$P(RTN,U)="" Q:$P(RTN,U,2)=""
- .S TEMP="S RET=$$"_RTN_"(.RESULT,PAT,VALUE,OVALUE,.INPUTS)"
- .X TEMP
- .S DONE=1
- .I FUNC>0,RESULT="" Q
- .;S ACT=$P(NODE,U,5) I ACT="" Q
- .S ORY=$S(ACT="C":"CHECKED",ACT="S":"SUPPRESS",ACT="R":"REQUIRED",ACT="V":RESULT,ACT="UC":"UNCHECKED",ACT="US":"UNSUPPRESS",1:"")
- .;S NODE=$G(^PXRMD(801.41,DIEN,10,CNT,0)) Q:LITEM'=$P(NODE,U,10) Q:LTYPE'=$P(NODE,U,11)
- .;S FUNC=$G(^PXRMD(801.41,DIEN,10,CNT,1)) Q:FUNC=""
- .;X FUNC S:$G(RESULT)'="" ORY=RESULT
- Q
- ;
- REMFUN(RESULT,IEN,PAT,VALUE,OVALUE) ;
- N INPUTS,NODE,NUM,RTN,RET,SUB,VAL,TEMP
- S RTN=$P($G(^PXRMD(801.47,IEN,0)),U,2,3) Q:$P(RTN,U)="" Q:$P(RTN,U,2)=""
- S NUM=0 F S NUM=$O(^PXRMD(801.48,IEN,2,NUM)) Q:NUM'>0 D
- .S NODE=$G(^PXRMD(801.48,IEN,2,NUM,0)),SUB=$P(NODE,U),VAL=$P(NODE,U,2) Q:SEQ="" Q:VAL=""
- .S INPUTS(SUB)=VAL
- S TEMP="S RET=$$"_RTN_"(.RESULT,PAT,VALUE,OVALUE,.INPUTS)"
- X TEMP
- Q
- ;
- WH(ORY,RESULT) ;
- N CNT,CNT1,CNT2,NODE,PIECNT,PUR,TYPE,TYP1,WVIEN,WVRESULT,WVNOT,WVPURIEN
- N PRINT
- K ^TMP("WV RPT",$J)
- I '$D(RESULT) Q
- S (CNT2,WVPURIEN,PUR)=0
- S CNT=0 F S CNT=$O(RESULT(CNT)) Q:CNT="" D
- . I $P($G(RESULT(CNT)),U)["WHIEN" D
- . . S CNT2=CNT2+1
- . . S WVIEN=$P($P($G(RESULT(CNT)),U),":",2),WVRESULT(CNT2)=$G(WVIEN)
- . . S WVRESULT(CNT2)=WVRESULT(CNT2)_U_$P($P($G(RESULT(CNT)),U,3),":",2)
- . I $P($G(RESULT(CNT)),U)["WHPur" D
- . . S NODE=$G(RESULT(CNT)),PUR=$P($P($G(NODE),U),":",2)
- . . S CNT1=1,TYPE=$P($G(NODE),U,2)
- . . I TYPE'[":" D
- ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$P($G(NODE),U,2)_U_$P($G(NODE),U,3)_U_$P($P($G(NODE),U,4),":",2)
- ..I TYPE[":" D
- ...S PIECNT=0
- ...F X=1:1:$L(TYPE) I $E(TYPE,X)=":" S PIECNT=PIECNT+1 I PIECNT>0 D
- ....S PRINT=""
- ....S TYP1=$P($G(TYPE),":",PIECNT)
- ....I TYP1="L" S PRINT=$P($G(NODE),U,3)
- ....S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2),CNT1=CNT1+1
- ...S PIECNT=PIECNT+1
- ...S PRINT=""
- ...S TYP1=$P($G(TYPE),":",PIECNT)
- ...I TYP1="L" S PRINT=$P($G(NODE),U,3)
- ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2)
- K WHMUFIND,WHFIND,WHNAME
- D NEW^WVRPCNO(.WVRESULT,.WVNOT)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMRPCC 6530 printed Jan 18, 2025@02:50:09 Page 2
- PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;01/11/2022
- +1 ;;2.0;CLINICAL REMINDERS;**6,45,65**;Feb 04, 2005;Build 438
- +2 ;
- +3 ; API ICR
- +4 ;$$GET^XPAR 2263
- +5 ;SHOWALL^YTQPXRM5 5056
- +6 ;SAVECR^YTQPXRM4 4463
- +7 ;NEW^WVRPCNO 4104
- +8 ;
- ACTIVE(ORY,ORREM) ;Check if active dialog exist for reminders
- +1 ;
- +2 ; input parameter ORREM is array of reminder ien [.01#811.9]
- +3 NEW DDIS,DIEN,OCNT,RIEN,RSTA
- +4 SET OCNT=0
- SET RIEN=0
- +5 ;Get reminder ien from array
- +6 FOR
- SET RIEN=$ORDER(ORREM(RIEN))
- if 'RIEN
- QUIT
- Begin DoDot:1
- +7 ;Dialog ien for reminder
- +8 SET DIEN=$PIECE($GET(^PXD(811.9,RIEN,51)),U)
- SET RSTA=0
- +9 ;Dialog status
- +10 IF DIEN
- SET DDIS=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,3)
- +11 ;If dialog and dialog not disabled
- +12 IF DIEN
- IF +DDIS=0
- SET RSTA=1
- +13 ;Return reminder and if active dialog exists
- +14 SET OCNT=OCNT+1
- SET ORY(OCNT)=RIEN_U_RSTA
- End DoDot:1
- +15 QUIT
- +16 ;
- +17 ;
- DIALOG(ORY,ORREM,DFN,VISITID) ;Load reminder dialog associated with the reminder
- +1 ;
- +2 ; input parameter ORREM - reminder ien [.01,#811.9]
- +3 ;
- +4 SET RIEN=ORREM
- +5 NEW DATA,DIEN
- +6 SET DIEN=$GET(^PXD(811.9,ORREM,51))
- +7 ;
- +8 ;Quit if no dialog for this reminder
- +9 IF 'DIEN
- SET ORY(1)="-1^no dialog for this reminder"
- QUIT
- +10 ;
- +11 ;Check if a reminder dialog and enabled
- +12 SET DATA=$GET(^PXRMD(801.41,DIEN,0))
- +13 ;
- +14 IF $PIECE(DATA,U,4)'="R"
- SET ORY(1)="-1^reminder dialog invalid"
- QUIT
- +15 ;
- +16 IF $PIECE(DATA,U,3)
- SET ORY(1)="-1^reminder dialog disabled"
- QUIT
- +17 ;
- +18 ;Load dialog lines into local array
- +19 SET ORY(0)=0_U_+$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,17)
- +20 DO LOAD^PXRMDLL(DIEN,$GET(DFN),VISITID)
- +21 QUIT
- +22 ;
- HDR(ORY,ORLOC) ;Progress Note Header by location/service/user
- +1 NEW ORSRV,PASS
- +2 ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
- +3 SET ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
- +4 SET PASS=DUZ_";VA(200,"
- +5 IF +$GET(ORLOC)
- SET PASS=PASS_"^LOC.`"_ORLOC
- +6 IF ORSRV>0
- SET PASS=PASS_"^SRV.`"_+$GET(ORSRV)
- +7 SET ORY=$$GET^XPAR(PASS_"^DIV^SYS^PKG","PXRM PROGRESS NOTE HEADERS",1,"Q")
- +8 QUIT
- +9 ;
- PROMPT(ORY,ORDLG,ORDCUR,ORFTYP,ORIEN,NDATA) ;Load additional prompts for a dialog element
- +1 ;
- +2 ; input parameters
- +3 ;
- +4 ; ORDLG - dialog element ien [.01,#801.41]
- +5 ; ORDCUR - 0 = current, 1 = Historical for taxonomies only
- +6 ; ORFTYP - finding type (CPT/POV) for taxonomies only
- +7 ; ORIEN - dialog ien [.01,#801.41]
- +8 ;
- +9 ; These fields can be found in the output array of DIALOG^PXRMRPCC
- +10 ;
- +11 DO LOAD^PXRMDLLA(ORDLG,ORDCUR,$GET(ORFTYP),$GET(ORIEN),$GET(NDATA))
- +12 QUIT
- +13 ;
- RES(ORY,ORREM) ; Reminder Resources/Inquiry
- +1 ;
- +2 ; input parameter ORREM - reminder ien [.01,#811.9]
- +3 ;
- +4 DO REMVAR^PXRMINQ(.ORY,ORREM)
- +5 QUIT
- +6 ;
- MH(ORY,OTEST) ; Mental Health dialog
- +1 ;
- +2 ; Input mental health instrument NAME
- +3 ;
- +4 KILL ^TMP($JOB,"YSQU")
- +5 NEW ARRAY,CNT,CNT1,FNODE,FSUB,IC,NODE,OCNT,SUB,YS
- +6 SET YS("CODE")=OTEST
- DO SHOWALL^YTQPXRM5(.ARRAY,.YS)
- +7 SET OCNT=0
- SET CNT=0
- +8 SET SUB="ARRAY"
- SET OCNT=0
- +9 FOR
- SET SUB=$QUERY(@SUB)
- if SUB=""
- QUIT
- Begin DoDot:1
- +10 SET FSUB=$PIECE($PIECE(SUB,"(",2),")")
- SET FNODE=""
- +11 FOR IC=1:1
- SET NODE=$PIECE(FSUB,",",IC)
- if NODE=""
- QUIT
- Begin DoDot:2
- +12 IF $EXTRACT(NODE)=""""
- SET NODE=$PIECE(NODE,"""",2)
- +13 SET $PIECE(FNODE,";",IC)=NODE
- End DoDot:2
- +14 if FNODE=""
- QUIT
- +15 SET OCNT=OCNT+1
- SET ORY(OCNT)=FNODE_U_@SUB
- End DoDot:1
- +16 QUIT
- +17 ;
- MHR(ORY,RESULT,ORES) ; Mental Health score and P/N text
- +1 ;
- +2 ; Input MH result IEN and mental health instrument response
- +3 ;
- +4 DO START^PXRMDLR(.ORY,RESULT,.ORES)
- +5 ;
- +6 QUIT
- +7 ;
- MHS(ORY,YS) ; Mental Health save response
- +1 ;
- +2 ; Input mental health instrument response
- +3 NEW ANS,ARRAY,X
- +4 SET ANS=$GET(YS("R1"))
- KILL YS("R1")
- +5 SET YS("ADATE")=YS("ADATE")_"."_$PIECE($$NOW^XLFDT,".",2)
- +6 FOR X=1:1:$LENGTH(ANS)
- IF $EXTRACT(ANS,X)'="X"
- SET YS(X)=X_U_$EXTRACT(ANS,X)
- +7 DO SAVECR^YTQPXRM4(.ARRAY,.YS)
- +8 QUIT
- +9 ;
- MST(ORY,DFN,DGMSTDT,DGMSTSC,DGMSTPR,FTYP,FIEN,RESULT) ; File MST status
- +1 ;This is obsolete and can be removed when the GUI is changed not
- +2 ;to use it.
- +3 QUIT
- +4 ;
- PROMPTVL(ORY,VALUE,DIEN,OVALUE,PAT) ; Calculate prompt value
- +1 NEW ACT,DONE,FUNC,NODE,CNT,FUNC,INPUTS,LINK,NUM,RESULT,RTN,SUB,TEMP,VAL
- +2 SET CNT=0
- SET DONE=0
- FOR
- SET CNT=$ORDER(^PXRMD(801.41,DIEN,10,CNT))
- if CNT'>0!(DONE=1)
- QUIT
- Begin DoDot:1
- +3 SET LINK=$PIECE($GET(^PXRMD(801.41,DIEN,10,CNT,"LINK")),U)
- if LINK'>0
- QUIT
- +4 SET NODE=^PXRMD(801.48,LINK,0)
- +5 SET FUNC=$PIECE($GET(NODE),U,4)
- IF FUNC'>0
- QUIT
- +6 SET ACT=$PIECE(NODE,U,5)
- IF ACT=""
- QUIT
- +7 ;build additional inputs
- +8 SET NUM=0
- FOR
- SET NUM=$ORDER(^PXRMD(801.48,LINK,2,NUM))
- if NUM'>0
- QUIT
- Begin DoDot:2
- +9 SET NODE=$GET(^PXRMD(801.48,LINK,2,NUM,0))
- SET SUB=$PIECE(NODE,U)
- SET VAL=$PIECE(NODE,U,2)
- if SUB=""
- QUIT
- if VAL=""
- QUIT
- +10 SET INPUTS(SUB)=VAL
- End DoDot:2
- +11 ;AGP do we need to still check item and prompt value??
- +12 ;S RESULT="",FUNC=$P($G(NODE),U,4) I FUNC>0 D REMFUN(.RESULT,FUNC,PAT,VALUE,OVALUE)
- +13 SET RESULT=""
- SET RTN=$PIECE($GET(^PXRMD(801.47,FUNC,0)),U,2,3)
- if $PIECE(RTN,U)=""
- QUIT
- if $PIECE(RTN,U,2)=""
- QUIT
- +14 SET TEMP="S RET=$$"_RTN_"(.RESULT,PAT,VALUE,OVALUE,.INPUTS)"
- +15 XECUTE TEMP
- +16 SET DONE=1
- +17 IF FUNC>0
- IF RESULT=""
- QUIT
- +18 ;S ACT=$P(NODE,U,5) I ACT="" Q
- +19 SET ORY=$SELECT(ACT="C":"CHECKED",ACT="S":"SUPPRESS",ACT="R":"REQUIRED",ACT="V":RESULT,ACT="UC":"UNCHECKED",ACT="US":"UNSUPPRESS",1:"")
- +20 ;S NODE=$G(^PXRMD(801.41,DIEN,10,CNT,0)) Q:LITEM'=$P(NODE,U,10) Q:LTYPE'=$P(NODE,U,11)
- +21 ;S FUNC=$G(^PXRMD(801.41,DIEN,10,CNT,1)) Q:FUNC=""
- +22 ;X FUNC S:$G(RESULT)'="" ORY=RESULT
- End DoDot:1
- +23 QUIT
- +24 ;
- REMFUN(RESULT,IEN,PAT,VALUE,OVALUE) ;
- +1 NEW INPUTS,NODE,NUM,RTN,RET,SUB,VAL,TEMP
- +2 SET RTN=$PIECE($GET(^PXRMD(801.47,IEN,0)),U,2,3)
- if $PIECE(RTN,U)=""
- QUIT
- if $PIECE(RTN,U,2)=""
- QUIT
- +3 SET NUM=0
- FOR
- SET NUM=$ORDER(^PXRMD(801.48,IEN,2,NUM))
- if NUM'>0
- QUIT
- Begin DoDot:1
- +4 SET NODE=$GET(^PXRMD(801.48,IEN,2,NUM,0))
- SET SUB=$PIECE(NODE,U)
- SET VAL=$PIECE(NODE,U,2)
- if SEQ=""
- QUIT
- if VAL=""
- QUIT
- +5 SET INPUTS(SUB)=VAL
- End DoDot:1
- +6 SET TEMP="S RET=$$"_RTN_"(.RESULT,PAT,VALUE,OVALUE,.INPUTS)"
- +7 XECUTE TEMP
- +8 QUIT
- +9 ;
- WH(ORY,RESULT) ;
- +1 NEW CNT,CNT1,CNT2,NODE,PIECNT,PUR,TYPE,TYP1,WVIEN,WVRESULT,WVNOT,WVPURIEN
- +2 NEW PRINT
- +3 KILL ^TMP("WV RPT",$JOB)
- +4 IF '$DATA(RESULT)
- QUIT
- +5 SET (CNT2,WVPURIEN,PUR)=0
- +6 SET CNT=0
- FOR
- SET CNT=$ORDER(RESULT(CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +7 IF $PIECE($GET(RESULT(CNT)),U)["WHIEN"
- Begin DoDot:2
- +8 SET CNT2=CNT2+1
- +9 SET WVIEN=$PIECE($PIECE($GET(RESULT(CNT)),U),":",2)
- SET WVRESULT(CNT2)=$GET(WVIEN)
- +10 SET WVRESULT(CNT2)=WVRESULT(CNT2)_U_$PIECE($PIECE($GET(RESULT(CNT)),U,3),":",2)
- End DoDot:2
- +11 IF $PIECE($GET(RESULT(CNT)),U)["WHPur"
- Begin DoDot:2
- +12 SET NODE=$GET(RESULT(CNT))
- SET PUR=$PIECE($PIECE($GET(NODE),U),":",2)
- +13 SET CNT1=1
- SET TYPE=$PIECE($GET(NODE),U,2)
- +14 IF TYPE'[":"
- Begin DoDot:3
- +15 SET WVNOT(PUR,CNT1)=$PIECE($GET(NODE),U,5)_U_$PIECE($GET(NODE),U,2)_U_$PIECE($GET(NODE),U,3)_U_$PIECE($PIECE($GET(NODE),U,4),":",2)
- End DoDot:3
- +16 IF TYPE[":"
- Begin DoDot:3
- +17 SET PIECNT=0
- +18 FOR X=1:1:$LENGTH(TYPE)
- IF $EXTRACT(TYPE,X)=":"
- SET PIECNT=PIECNT+1
- IF PIECNT>0
- Begin DoDot:4
- +19 SET PRINT=""
- +20 SET TYP1=$PIECE($GET(TYPE),":",PIECNT)
- +21 IF TYP1="L"
- SET PRINT=$PIECE($GET(NODE),U,3)
- +22 SET WVNOT(PUR,CNT1)=$PIECE($GET(NODE),U,5)_U_$GET(TYP1)_U_$GET(PRINT)_U_$PIECE($PIECE($GET(NODE),U,4),":",2)
- SET CNT1=CNT1+1
- End DoDot:4
- +23 SET PIECNT=PIECNT+1
- +24 SET PRINT=""
- +25 SET TYP1=$PIECE($GET(TYPE),":",PIECNT)
- +26 IF TYP1="L"
- SET PRINT=$PIECE($GET(NODE),U,3)
- +27 SET WVNOT(PUR,CNT1)=$PIECE($GET(NODE),U,5)_U_$GET(TYP1)_U_$GET(PRINT)_U_$PIECE($PIECE($GET(NODE),U,4),":",2)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +28 KILL WHMUFIND,WHFIND,WHNAME
- +29 DO NEW^WVRPCNO(.WVRESULT,.WVNOT)
- +30 QUIT
- +31 ;