QANCNV2 ;HISC/GJC-Cleanup and utilities for data conversions ;10/9/92
;;2.0;Incident Reporting;**1,4**;08/07/1992
;
KILL ;Kill variables, and quit
K C,DA,DD,DFN,DIC,DIK,DINUM,DLAYGO,DO,DOT,I,PRMQ0,PRMQ1,PRMQ2,PRMQ5
K PRMQ8,PRMQAS,PRMQDFN,PRMQDISP,PRMQFF,PRMQI,PRMQIEN,PRMQINC,PRMQME
K PRMQMS,PRMQPM,PRMQST,PRMQSTA,PRMQYR,QA,QAALPHA,QAN,QANADMDT,QANBAD
K QANCASE,QANCNT,QANCT,QANDATE,QANDESC,QANDSCPT,QANFLG,QANIEN,QANINCD
K QANLOC0,QANLOC1,QANLVL,QANMED,QANMSSG,QANNODE,QANPAT,QANPID,QANPTY
K QANRPT,QANSERV,QANSLEV,QANSTRG,QANSUB,QANSUB1,QANTREAT,QANVV,QANWARD
K QANNON,QANWT,QANXIT,QANXX,QANZZ,QAQ0,VAIN,VAINDT,X,Y
Q
DESC ;Description node.
Q:'QANDSCPT
S ^QA(742.4,QANIEN(7424),1,0)="^^^^"_DT_"^^^^" ;set the zero node of the multiple.
S QANSUB="",QANCNT=0
F S QANSUB=$O(^TMP($J,QANSUB)) Q:QANSUB="" D:QANSUB["QAN DESC "
. S QANSTRG=$P(QANSUB,"QAN DESC ",2)_": ",QANCNT=QANCNT+1,QANSUB1=""
. F S QANSUB1=$O(^TMP($J,QANSUB,QANSUB1)) Q:QANSUB1="" D
.. I ($L(QANSTRG)+$L(QANSUB1))'>200 S QANSTRG=QANSTRG_QANSUB1_"," Q
.. I $E(QANSTRG,$L(QANSTRG))="," S QANSTRG=$E(QANSTRG,1,$L(QANSTRG)-1)
.. S ^QA(742.4,QANIEN(7424),1,QANCNT,0)=QANSTRG,QANCNT=QANCNT+1
.. S QANSTRG=""
.. Q
. I $E(QANSTRG,$L(QANSTRG))="," S QANSTRG=$E(QANSTRG,1,$L(QANSTRG)-1)
. S ^QA(742.4,QANIEN(7424),1,QANCNT,0)=QANSTRG
. Q
S ^QA(742.4,QANIEN(7424),1,0)="^^"_QANCNT_"^"_QANCNT_"^"_DT_"^^^^"
Q
SERV ;Service conversion.
F QAN=0:0 S QAN=$O(^PRMQ(513.72,PRMQIEN,6,QAN)) Q:QAN'>0 D
. S QANSERV=+$P(^PRMQ(513.72,PRMQIEN,6,QAN,0),U)
. Q:'$D(^DIC(49,QANSERV,0))
. S QANSERV(0)=$P(^DIC(49,QANSERV,0),U) Q:QANSERV(0)']""
. I $D(^ECC(730,"B",QANSERV(0))) D
.. S QANSERV(1)=$O(^ECC(730,"B",QANSERV(0),0))
.. S:QANSERV(1)]"" ^TMP($J,"QAN RESPONSIBLE SERVICE",QANSERV(1))=""
.. Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANCNV2 1825 printed Apr 09, 2024@21:02 Page 2
QANCNV2 ;HISC/GJC-Cleanup and utilities for data conversions ;10/9/92
+1 ;;2.0;Incident Reporting;**1,4**;08/07/1992
+2 ;
KILL ;Kill variables, and quit
+1 KILL C,DA,DD,DFN,DIC,DIK,DINUM,DLAYGO,DO,DOT,I,PRMQ0,PRMQ1,PRMQ2,PRMQ5
+2 KILL PRMQ8,PRMQAS,PRMQDFN,PRMQDISP,PRMQFF,PRMQI,PRMQIEN,PRMQINC,PRMQME
+3 KILL PRMQMS,PRMQPM,PRMQST,PRMQSTA,PRMQYR,QA,QAALPHA,QAN,QANADMDT,QANBAD
+4 KILL QANCASE,QANCNT,QANCT,QANDATE,QANDESC,QANDSCPT,QANFLG,QANIEN,QANINCD
+5 KILL QANLOC0,QANLOC1,QANLVL,QANMED,QANMSSG,QANNODE,QANPAT,QANPID,QANPTY
+6 KILL QANRPT,QANSERV,QANSLEV,QANSTRG,QANSUB,QANSUB1,QANTREAT,QANVV,QANWARD
+7 KILL QANNON,QANWT,QANXIT,QANXX,QANZZ,QAQ0,VAIN,VAINDT,X,Y
+8 QUIT
DESC ;Description node.
+1 if 'QANDSCPT
QUIT
+2 ;set the zero node of the multiple.
SET ^QA(742.4,QANIEN(7424),1,0)="^^^^"_DT_"^^^^"
+3 SET QANSUB=""
SET QANCNT=0
+4 FOR
SET QANSUB=$ORDER(^TMP($JOB,QANSUB))
if QANSUB=""
QUIT
if QANSUB["QAN DESC "
Begin DoDot:1
+5 SET QANSTRG=$PIECE(QANSUB,"QAN DESC ",2)_": "
SET QANCNT=QANCNT+1
SET QANSUB1=""
+6 FOR
SET QANSUB1=$ORDER(^TMP($JOB,QANSUB,QANSUB1))
if QANSUB1=""
QUIT
Begin DoDot:2
+7 IF ($LENGTH(QANSTRG)+$LENGTH(QANSUB1))'>200
SET QANSTRG=QANSTRG_QANSUB1_","
QUIT
+8 IF $EXTRACT(QANSTRG,$LENGTH(QANSTRG))=","
SET QANSTRG=$EXTRACT(QANSTRG,1,$LENGTH(QANSTRG)-1)
+9 SET ^QA(742.4,QANIEN(7424),1,QANCNT,0)=QANSTRG
SET QANCNT=QANCNT+1
+10 SET QANSTRG=""
+11 QUIT
End DoDot:2
+12 IF $EXTRACT(QANSTRG,$LENGTH(QANSTRG))=","
SET QANSTRG=$EXTRACT(QANSTRG,1,$LENGTH(QANSTRG)-1)
+13 SET ^QA(742.4,QANIEN(7424),1,QANCNT,0)=QANSTRG
+14 QUIT
End DoDot:1
+15 SET ^QA(742.4,QANIEN(7424),1,0)="^^"_QANCNT_"^"_QANCNT_"^"_DT_"^^^^"
+16 QUIT
SERV ;Service conversion.
+1 FOR QAN=0:0
SET QAN=$ORDER(^PRMQ(513.72,PRMQIEN,6,QAN))
if QAN'>0
QUIT
Begin DoDot:1
+2 SET QANSERV=+$PIECE(^PRMQ(513.72,PRMQIEN,6,QAN,0),U)
+3 if '$DATA(^DIC(49,QANSERV,0))
QUIT
+4 SET QANSERV(0)=$PIECE(^DIC(49,QANSERV,0),U)
if QANSERV(0)']""
QUIT
+5 IF $DATA(^ECC(730,"B",QANSERV(0)))
Begin DoDot:2
+6 SET QANSERV(1)=$ORDER(^ECC(730,"B",QANSERV(0),0))
+7 if QANSERV(1)]""
SET ^TMP($JOB,"QAN RESPONSIBLE SERVICE",QANSERV(1))=""
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
